Convert Single Pair of Columns to 3 Column (Pair) List

I want to convert a list of names and values listed as follows:

NAME AMOUNT
Name1 Value1
Name2 Value2
Name3 Value3
Name4 Value4
Name5 Value5
Name6 Value6
Name7 Value7
Name8 Value8

etc

into 3 pairs of equal length columns with headers



NAME AMOUNT NAME AMOUNT NAME AMOUNT
Name1 Value1 Name43 Value43 Name76 Value76
Name2 Value2 Name44 Value44 Name77 Value77
Name3 Value3 Name45 Value45 Name78 Value78
Name4 Value4 Name46 Value46 Name79 Value79
Name5 Value5 Name47 Value47 Name80 Value80
Name6 Value6 Name48 Value48 Name81 Value81
Name7 Value7 Name49 Value49 Name82 Value82
Name8 Value8 Name50 Value50
etc etc remainder in 3rd column

I am able to determine the number of rows in each column by using the Int and Mod function after counting the number of entries in the original list.

Sub ThreeColumns()

Dim ThreeColums() As Variant
Dim Rows As Long, Columns As Long


Sheet1.Activate ' to ensure we are on the correct worksheet

Rows = Range("A1", Range("A1").End(xlDown)).Cells.Count - 1
Columns = Range("A1", Range("A1").End(xlToRight)).Cells.Count - 1

ReDim ThreeColumns(0 To Rows, 0 To Columns)

Etc.....

End Sub

I can figure out how to find the length of each column using the Int and Mod process on the Rows value but I cannot figure out the the code to read the original pairs of values from the list and then write these values into the 3 column pairs shown above.

I would be grateful if someone would kindly help.

Thank you for your speedy response. It is late here in the UK and so I will give it a go over the weekend and let you know the outcome.

I used the code to produce the result shown in the attached file ThreeColumns1.jpg
I tried to change the code to produce the result that I actually want in attached file ThreeColumns2.jpg
but without much success. Sadly my knowledge of the more advanced VBA code that you used is lacking.

I would be grateful if you would amend the code to:

1. Copy the Name and Subs values from cells starting on Row 8 (for example)
2. Copy and write the Name and Subs values starting at Row 9 and writing them into 3 columns with labels to produce the desired result (Three Columns2.jpg)
3. Change the column widths to set values as shown in ThreeColumns2.

Many thanks for providing the original code and I hope I am not asking too much for the additional modifications to the code.

I am sorry that it has taken some time to respond to this topic - I have been away on holiday. I used your revised code and it worked. Many thanks for your assistance.

I have finally got round to solving the problem with your assistance. I used the
following VBA code to generate 3 equal sized columns from a long list (one column).

Option Explicit

Sub Generate_Bagman_List()
'
' Clear_"Bagman"_Contents Macro
'
    Sheets("Bagman").Select
    Columns("A:I").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select

' Copy_"Members"_To_"Bagman" Macro
'
    Sheets("Members").Select
    Range("C3", Range("B3").End(xlDown)).Select
    Selection.Copy
    Range("A1").Select
    Sheets("Bagman").Select
    Columns("A:B").Select
    ActiveSheet.Paste
    Range("A1").Select
    
' Convert One Pair of Columns to Three Pairs of Columns
    
    Dim lngR As Long
    Dim lngC As Long
    Dim lngHeaderRow As Long
    Dim strCol As String
    
    lngHeaderRow = 1
    strCol = "A"
    
    With Sheet14
        lngR = .Cells(.Rows.Count, strCol).End(xlUp).Row - lngHeaderRow
        lngC = .Cells(lngHeaderRow, .Columns.Count).End(xlToLeft).CurrentRegion.Columns.Count
        'Copy headers
        .Cells(lngHeaderRow, strCol).Resize(1, lngC).Copy .Cells(lngHeaderRow, strCol).Offset(0, lngC + 1)
        .Cells(lngHeaderRow, strCol).Resize(1, lngC).Copy .Cells(lngHeaderRow, strCol).Offset(0, 2 * lngC + 2)
        'Move data
        .Cells(lngHeaderRow, strCol).Offset(1 + 2 * (lngR \ 3) + lngR Mod 3, 0).Resize(lngR \ 3, lngC).Cut .Cells(lngHeaderRow, strCol).Offset(1, 2 * lngC + 2)
        .Cells(lngHeaderRow, strCol).Offset(1 + lngR \ 3 + IIf(lngR Mod 3 >= 1, 1, 0), 0).Resize(lngR \ 3 + IIf(lngR Mod 3 >= 1, 1, 0), lngC).Cut .Cells(lngHeaderRow, strCol).Offset(1, lngC + 1)
    End With
    Cells.EntireColumn.AutoFit
'
' Format_"Bagman" Macro
'
    Columns("A:A").Select
    Range("A13").Activate
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveWindow.SmallScroll Down:=-48
    Rows("1:4").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("B:B,E:E,H:H").Select
    Range("H1").Activate
    Selection.ColumnWidth = 25
    Range("C:C,F:F").Select
    Range("F1").Activate
    Application.Width = 988.5
    Application.Height = 785.25
    Range("C:C,F:F,I:I").Select
    Range("I1").Activate
    Selection.ColumnWidth = 8
    Range("A:A,D:D,G:G").Select
    Range("G1").Activate
    Selection.ColumnWidth = 5
    Range("B1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "VETS SECTION MEMBERSHIP - 2017"
    Range("G1").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Updated:  " & Date
    Range("B3").Select
    Selection.Font.Bold = True
    ActiveCell.FormulaR1C1 = "Vets membership showing who has paid 2017 subs (bagman to collect £10 subs from those who have not paid)."
    Range("A1").Select

End Sub