Copying data from Sheet1 which is on multiple rows for each customerto Sheet2 on single row.

[u473]

I have Customers data in the following format in Sheet(1) :
Col. A Col. B
Cust1 Name Cust1 Phone
Cust1 Address Cust1 Cell
Cust1 City Cust1 Email
Cust2 Name Cus2 Phone
Cust2 Address Cust2 Cell
Cus2 City Cust2 Email
Etc...
How do I export on Sheet(2) each customer data on a single line like :
Col. A Col.B Col. C Col.
D Col. E Col. F
Cust1 Name Cust1 Address Cust1 City Cust1 Phone Cust1 Cell
Cust1 Email
Cust2 Name Cust2 Address Cust2 City Cust2 Phone Cust2 Cell
Cust2 Email

Where did I go wrong with the following code ? Help appreciated

Sub CustListl()
Dim WS As Object
Dim LastRow Long
Dim R1 As Long ' Destination WorkSheet Start Row
R1 = 2
WS = ThisWorkbook.Sheets(2)
Application.ScreenUpdating = False
On Error Resume Next
Sheets(1).Activate
LastRow = Range("A65000").End(xlUp).Row
Range("A1").Select
Do
WS.Cells(R1, 1).Value = ActiveCell.Offset(0, 0) ' Name
WS.Cells(R1, 2).Value = ActiveCell.Offset(-1, 0) ' Address
WS.Cells(R1, 3).Value = ActiveCell.Offset(-2, 0) ' City
WS.Cells(R1,4).Value = ActiveCell.Offset(0, 1) ' Phone
WS.Cells(R1, 5).Value = ActiveCell.Offset(-1, 1) ' Cell
WS.Cells(R1, 6).Value = ActiveCell.Offset(-2, 1) ' City
R1 = R1 + 1
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Row > LastRow
Application.ScreenUpdating = True
End Sub

 

[Patrick Molloy]

4 issues.
1 - your DIM was wrong - missing 'AS'
2 - you need to SET an worksheet object to a sheet
3 - offseting a row down a sheet isn't -1. the row number increases...
4 - when yuo copied a row, you moved your sourcde to the next row, it should
be three rows down:


Option Explicit
Sub CustListl()
Dim WS As Object
Dim LastRow As Long
Dim R1 As Long ' ***
R1 = 2
Set WS = ThisWorkbook.Sheets(2) '***
Application.ScreenUpdating = False
On Error Resume Next
Sheets(1).Activate
LastRow = Range("A65000").End(xlUp).Row
Range("A1").Select
Do
WS.Cells(R1, 1).Value = ActiveCell.Offset(0, 0) ' Name
WS.Cells(R1, 2).Value = ActiveCell.Offset(1, 0) ' Address
WS.Cells(R1, 3).Value = ActiveCell.Offset(2, 0) ' City
WS.Cells(R1, 4).Value = ActiveCell.Offset(0, 1) ' Phone
WS.Cells(R1, 5).Value = ActiveCell.Offset(1, 1) ' Cell
WS.Cells(R1, 6).Value = ActiveCell.Offset(2, 1) ' City
R1 = R1 + 1
ActiveCell.Offset(3, 0).Select '***
Loop Until ActiveCell.Row > LastRow
Application.ScreenUpdating = True
End Sub

Option Explicit

Sub CustListl()
Dim WS As Object
Dim LastRow As Long
Dim R1 As Long ' ***
R1 = 2
Set WS = ThisWorkbook.Sheets(2) '***
Application.ScreenUpdating = False
On Error Resume Next
Sheets(1).Activate
LastRow = Range("A65000").End(xlUp).Row
Range("A1").Select
Do
WS.Cells(R1, 1).Value = ActiveCell.Offset(0, 0) ' Name
WS.Cells(R1, 2).Value = ActiveCell.Offset(1, 0) ' Address
WS.Cells(R1, 3).Value = ActiveCell.Offset(2, 0) ' City
WS.Cells(R1, 4).Value = ActiveCell.Offset(0, 1) ' Phone
WS.Cells(R1, 5).Value = ActiveCell.Offset(1, 1) ' Cell
WS.Cells(R1, 6).Value = ActiveCell.Offset(2, 1) ' City
R1 = R1 + 1
ActiveCell.Offset(3, 0).Select
Loop Until ActiveCell.Row > LastRow
Application.ScreenUpdating = True
End Sub

 

[u473]

Thanks a lot, it works fine.
Could I ask you to show me the changes /additions
if I am calling the execution from the Destination worksheet
and the Source worksheet is in a separate closed workbook ?
That may be basics but I have to understand that minimum sequence
of code.
Thanks again