Macro to transfer cells in one col to diff cols

[Excelriver]

Would like to be able to have 3 items listed under each other in Col A transfer to the same line in col B and Col C.........so that the top item in col A stays on that same line, with the one below transfered to col B on the same line as col A, and the 3rd item under that transfered to col C on the same line as col A.

Have list of name, phone, and address listed in col A underneath each other and would like to have them transfer to the same line in three diff cols on same line.

Thanks for any help you can give........I am new at EXCEL macros.
Thanks
Excelriver

 

[xenou]

Hi Welcome,

Here's one strategy, among many others I'm sure:

Sub MoveCellsOutInThrees()
Dim ws As Worksheet
Dim LRow As Long
Dim a
Dim x As Long
Const intSTART_ROW As Integer = 1
Const intIN_COLUMN As Integer = 1
Const rngPASTE_NEW_VALUES_AT As String = "$B$1"
'---------------------------------------------------

Set ws = ActiveSheet
LRow = Cells(Rows.Count, intIN_COLUMN).End(xlUp).Row

With ws
    'Write values to array a
    a = .Range(.Cells(intSTART_ROW, intIN_COLUMN), .Cells(LRow, intIN_COLUMN)).Value
    
    'Check for that number of cells is a factor of three
    If UBound(a, 1) Mod 3 <> 0 Then GoTo Handler:
        
    'Write to new range
    With .Range(rngPASTE_NEW_VALUES_AT).Resize(Int(UBound(a, 1) / 3), 3)
        For x = 1 To UBound(a, 1)
            .Cells(x).Value = a(x, 1)
        Next x
    End With
End With

Exit Sub
Handler:
MsgBox "The rows to process must be divisible by three.  Code aborted."
End Sub

Hope this helps!
AB

Code placement is in a standard module. For more see:
http://www.mcgimpsey.com/excel/modules.html

 

[jindon]

try

Sub test()
With Range("a1", Range("a" & Rows.Count).End(xlUp))
    With .Offset(,1).Resize(,3)
        .Formula = Array("=if(mod(row(a1),3)=1,a1,false)", _
                    "=if(mod(row(a1),3)=1,a2,false)", _
                    "=if(mod(row(a1),3)=1,a3,false)")
        .Value = .Value
        .SpecialCells(2,4).ClearContents
    End With
End With
Columns(1).Delete
End Sub