Copying multiple cells in Excel - vba

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.
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.
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