Copying multiple cells in Excel

Question

I am new to this but I am trying to copy multiple cells in an excel workbook and paste them into a separate tab of the same workbook.

Above is a sample of what my spreadsheet looks like, but my spreadsheet has over 800 lines of data.

I need the names to be copied and put into column A of Sheet2 and then the account numbers into column D of Sheet2.

I have tried this 2 different ways.

1. Using below code:

   Sheets("Sheet1").Select
   Range("A1,A3,A5,A7,A9").Select    
   Range("A10").Activate
   Selection.Copy
   Sheets("Sheet2").Select
   Range("A1").Select
   ActiveSheet.Paste
   Sheets("Sheet1").Select
   Range("A2,A4,A6,A8,A10").Select    
   Range("A10").Activate
   Selection.Copy
   Sheets("Sheet2").Select
   Range("D1").Select
   ActiveSheet.Paste
   

   This gives me a Compile Error Syntax Error.

2. Code #2

   Range("A2").Select
   Selection.Cut
   Range("D1").Select
   ActiveSheet.Paste
   Range("A4").Select
   Selection.Cut
   Range("D3").Select
   ActiveSheet.Paste
   ...
   

   This is keeping them in the same tab, instead of pasting them into a separate tab (I would just copy them over later). I repeat this for each customer. This one gives me a range error that basically says it's too large. Unfortunately, I can't recreate it because I deleted it.

Does anyone have a simpler way of doing this that won't cause an error?

Answer 1

Try this is assuming your data is consistently alternating (Name,acount).

Sub marine()
    Dim lr As Long, i As Long
    Dim sh1 As Worksheet, sh2 As Worksheet
    '/* declare the worksheets and use variables in the rest of the code */
    Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")

    With sh1
        lr = .Range("A" & .Rows.Count).End(xlUp).Row '/* get the last row in Sheet1 */
        For i = 1 To lr '/* loop to all rows identified */
            If i Mod 2 = 1 Then '/* check if odd or even, copy in A if odd */
                .Range("A" & i).Copy _
                sh2.Range("A" & sh2.Rows.Count).End(xlUp).Offset(1, 0)
            Else '/* copy in D otherwise */
                .Range("A" & i).Copy _
                sh2.Range("D" & sh2.Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next
    End With
End Sub

Above copies data from Sheet1 to Sheet2 but leaves the 1st row blank.
Also, it always copy data on the last row of each column in Sheet2 (A and D).
So another approach would be:

Sub ject()
    Dim lr As Long, i As Long, lr2 As Long
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim rNames As Range, rAcct As Range
    Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")

    With sh1
        lr = .Range("A" & .Rows.Count).End(xlUp).Row
        For i = 1 To lr
            If i Mod 2 = 1 Then
                If rNames Is Nothing Then '/* get all the cells with names */
                    Set rNames = .Range("A" & i)
                Else
                    Set rNames = Union(rNames, .Range("A" & i))
                End If
            Else
                If rAcct Is Nothing Then '/* get all the cells with accounts */
                    Set rAcct = .Range("A" & i)
                Else
                    Set rAcct = Union(rAcct, .Range("A" & i))
                End If
            End If
        Next
    End With

    With sh2
        '/* get the last filled Names column in Sheet2 */
        lr2 = .Range("A" & .Rows.Count).End(xlUp).Row
        rNames.Copy .Range("A" & lr2) '/* execute 1 time copy */
        rAcct.Copy .Range("D" & lr2) '/* execute 1 time copy */
    End With
End Sub

Above code ensures that the correct account is adjacent to the correct name.
And you might gain execution performance too since one(1) time copy is executed. HTH.

P.S. As much as possible, avoid using Select.

Answer 2

Logic I implemented is to loop until last row in Sheet1 in step of 2. Loop variable indicates always row with name, the following row is account number, so it's easy in a loop to assign these values to particular columns on the other sheet. Also, I used another variable j, which indicates consecutive rows in Sheet2.

Solution:

Sub CopyData()

Dim sourceWs As Worksheet, targetWs As Worksheet, i As Long, lastRow As Long, j As Long
j = 1
Set sourceWs = Worksheets("Sheet1")
Set targetWs = Worksheets("Sheet2")
lastRow = sourceWs.Cells(sourceWs.Rows.Count, 1).End(xlUp).Row

For i = 1 To lastRow Step 2
    targetWs.Cells(j, 1) = sourceWs.Cells(i, 1)
    targetWs.Cells(j, 4) = sourceWs.Cells(i + 1, 1)
    j = j + 1
Next

End Sub