VBA - Copy specific columns from sheet2 into sheet1 within the same Workbook

[JTS25]

Hi all,

I have been working on the VBA for a little while now, and have figured it out. There are default headers, and the macro data starts on row2 for everything.

		Columns
Sheet1=Destination	A	B	C	F	I	L	P	S	V
Sheet2=Source	D	E	C	J	R	S	AA	AC	AI

<tbody>
</tbody>

I'm wondering if there is an easier or more desirable way to write this VBA? Below is what I have done so far that works, but it does take a while to run.

I've seen some other people asking for similar advice, and the VBA that I have seen from mumps and other pros looks different.

Sub copycol()
Dim lastrow As Long, erow As Long


Application.ScreenUpdating = False




'to check the last filled line on sheet named CMF DB
lastrow = Worksheets("CMF DB").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow






Worksheets("CMF DB").Cells(i, 4).Copy


' How many Rows are already filled
erow = Worksheets("Recon Master").Cells(Rows.Count, 1).End(xlUp).Row


Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 1)


Worksheets("CMF DB").Cells(i, 5).Copy
Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 2)


Worksheets("CMF DB").Cells(i, 3).Copy
Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 3)


Worksheets("CMF DB").Cells(i, 10).Copy
Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 6)


Worksheets("CMF DB").Cells(i, 18).Copy
Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 9)


Worksheets("CMF DB").Cells(i, 19).Copy
Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 12)


Worksheets("CMF DB").Cells(i, 27).Copy
Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 16)


Worksheets("CMF DB").Cells(i, 29).Copy
Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 19)


Worksheets("CMF DB").Cells(i, 35).Copy
Worksheets("CMF DB").Paste Destination:=Worksheets("Recon Master").Cells(erow + 1, 22)


Next i


Application.ScreenUpdating = True


End Sub

 

[mumps]

Try:

Sub copycol()
    Application.ScreenUpdating = False
    Dim lastRow As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("CMF DB")
    Set desWS = Sheets("Recon Master")
    lastRow = srcWS.Cells(Rows.Count, 1).End(xlUp).Row
    With scrws
        .Range("D2:E" & lastRow).Copy desWS.Range("A2")
        .Range("C2:C" & lastRow).Copy desWS.Range("C2")
        .Range("J2:J" & lastRow).Copy desWS.Range("F2")
        .Range("R2:S" & lastRow).Copy desWS.Range("I2")
        .Range("AA2:AA" & lastRow).Copy desWS.Range("P2")
        .Range("AC2:AC" & lastRow).Copy desWS.Range("S2")
        .Range("AI2:AI" & lastRow).Copy desWS.Range("V2")
    End With
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Please ignore the previous and use this version:

Sub copycol()
    Application.ScreenUpdating = False
    Dim lastRow As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("CMF DB")
    Set desWS = Sheets("Recon Master")
    lastRow = srcWS.Cells(Rows.Count, 1).End(xlUp).Row
    With scrws
        .Range("D2:D" & lastRow).Copy desWS.Range("A2")
        .Range("E2:E" & lastRow).Copy desWS.Range("B2")
        .Range("C2:C" & lastRow).Copy desWS.Range("C2")
        .Range("J2:J" & lastRow).Copy desWS.Range("F2")
        .Range("R2:R" & lastRow).Copy desWS.Range("I2")
        .Range("S2:S" & lastRow).Copy desWS.Range("L2")
        .Range("AA2:AA" & lastRow).Copy desWS.Range("P2")
        .Range("AC2:AC" & lastRow).Copy desWS.Range("S2")
        .Range("AI2:AI" & lastRow).Copy desWS.Range("V2")
    End With
    Application.ScreenUpdating = True
End Sub

 

[JTS25]

Please ignore the previous and use this version:

Sub copycol()
    Application.ScreenUpdating = False
    Dim lastRow As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("CMF DB")
    Set desWS = Sheets("Recon Master")
    lastRow = srcWS.Cells(Rows.Count, 1).End(xlUp).Row
    With scrws
        .Range("D2:D" & lastRow).Copy desWS.Range("A2")
        .Range("E2:E" & lastRow).Copy desWS.Range("B2")
        .Range("C2:C" & lastRow).Copy desWS.Range("C2")
        .Range("J2:J" & lastRow).Copy desWS.Range("F2")
        .Range("R2:R" & lastRow).Copy desWS.Range("I2")
        .Range("S2:S" & lastRow).Copy desWS.Range("L2")
        .Range("AA2:AA" & lastRow).Copy desWS.Range("P2")
        .Range("AC2:AC" & lastRow).Copy desWS.Range("S2")
        .Range("AI2:AI" & lastRow).Copy desWS.Range("V2")
    End With
    Application.ScreenUpdating = True
End Sub

Mumps, thank you for assisting. When I run the code, I'm getting an error (424 "Object Required")

When I clicked debug, it points to this line -- .Range("D2:D" & lastRow).Copy desWS.Range("A2")

 

[MARK858]

With scrws

needs changing to

With srcWs

 

[mumps]

@MARK858
Thanks for picking up on my typo.

 

[JTS25]

All,

I replaced scrws --> scrWS, and still recieving a "424" error, Object Required.

 

[MARK858]

You haven't replaced it with what I posted... look again.

 

[JTS25]

Wow, this is working perfectly and so much faster.

What is the difference between my code, and the revised code? I'm still very green with vba, and just learning on the fly.

 

[MARK858]

The main difference is the original code loops through each cell in each column and copies it whereas the amended code copies the complete range in each column and copies it in one go

For instance if lastrow was 10 then in the first code then you are copying the cells 9 times for each column, in the amended coded you are copying only once for each column. The less number of times you interact with the worksheet the faster the code.