Macro to copy specific columns from one workbook to another workbook

[whoosh]

Hi,

Hope someone can help me out on this. I'm trying to copy several columns from 1 workbook (Source File.xls - "sheet1") to another workbook (Target File.xlsm - worksheet ("final").

I need to run a macro to copy specific columns (A, B, C, F, G) from "Source" (but omitting the last 1 row "Not req") to (a, b, c, f, g) on "Target" without overwriting the existing data.

Source File
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[/TR]
[TR]
[TD]1111[/TD]
[TD]2222[/TD]
[TD]3333[/TD]
[TD]4444[/TD]
[TD]5555[/TD]
[TD]6666[/TD]
[TD]7777[/TD]
[/TR]
[TR]
[TD]fd[/TD]
[TD]sdfd[/TD]
[TD]dacd[/TD]
[TD]gdd[/TD]
[TD]sfafsd[/TD]
[TD]hgfgh[/TD]
[TD]xdvs[/TD]
[/TR]
[TR]
[TD]qe[/TD]
[TD]zccz[/TD]
[TD]gdfv[/TD]
[TD]xbbdbf[/TD]
[TD]vdsv[/TD]
[TD]sdvsd[/TD]
[TD]adsa[/TD]
[/TR]
[TR]
[TD]Not req[/TD]
[TD]Not req[/TD]
[TD]Not req[/TD]
[TD]Not req[/TD]
[TD]Not req[/TD]
[TD]Not req[/TD]
[TD]Not req[/TD]
[/TR]
</tbody>[/TABLE]

Target File
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]a[/TD]
[TD]a1[/TD]
[TD]a2[/TD]
[TD]b[/TD]
[TD]c[/TD]
[TD]c1[/TD]
[TD]d[/TD]
[TD]e[/TD]
[TD]f[/TD]
[TD]g[/TD]
[/TR]
[TR]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[/TR]
[TR]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[/TR]
[TR]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[TD]existing data[/TD]
[/TR]
[TR]
[TD]1111[/TD]
[TD][/TD]
[TD][/TD]
[TD]2222[/TD]
[TD]3333[/TD]
[TD][/TD]
[TD]4444[/TD]
[TD]5555[/TD]
[TD]6666[/TD]
[TD]7777[/TD]
[/TR]
[TR]
[TD]fd[/TD]
[TD][/TD]
[TD][/TD]
[TD]sdfd[/TD]
[TD]dacd[/TD]
[TD][/TD]
[TD]gdd[/TD]
[TD]sfafsd[/TD]
[TD]hgfgh[/TD]
[TD]xdvs[/TD]
[/TR]
[TR]
[TD]qe[/TD]
[TD][/TD]
[TD][/TD]
[TD]zccz[/TD]
[TD]gdfv[/TD]
[TD][/TD]
[TD]xbbdbf[/TD]
[TD]vdsv[/TD]
[TD]sdvsd[/TD]
[TD]adsa[/TD]
[/TR]
</tbody>[/TABLE]

I have tried some codes but it doesn't deliver what I want. My apology, don't know how to attach files.

Sub CopySource()


    Dim SourceWB As Workbook: Set SourceWB = Workbooks("Source File.xlsx")
    Dim TargetWB As Workbook: Set TargetWB = Workbooks("Target File.xlsm")
    Dim lr As Long: lr = SourceWB.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    Dim lastr As Long: lastr = TargetWB.Sheets("Final").Cells(Rows.Count, "A").End(xlUp).Row
    
    SourceWB.Sheets("Sheet1").Range("A2:H5000").Copy Destination:=TargetWB.Sheets("Final").Range("A" & lr)


End Sub

Thanks in advance

 

[Yongle]

Try this
- place code in a standard module in target file and amend source

The code
- adds a temporary sheet
- opens source file
- copies relevant range to temporary sheet
- closes source file (without saving)
- inserts 3 columns
- copies range to sheet "Final" in target file
- deletes temporary sheet

Sub AddData()
    Const source = "[COLOR=#ff0000]C:\Folder\SubFolder\Source File.xlsx[/COLOR]"
    Dim sourceWB As Workbook, targetWB As Workbook
    Dim sourceWS As Worksheet, targetWS As Worksheet, tempWS As Worksheet
    Dim sourceRNG As Range
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationAutomatic
    End With
    
    Set sourceWB = Workbooks.Open(source)
    Set targetWB = ThisWorkbook
    Set tempWS = targetWB.Worksheets.Add
    Set sourceWS = sourceWB.Sheets("Sheet1")
    Set targetWS = targetWB.Sheets("Final")
    Set sourceRNG = sourceWS.Range("A2", sourceWS.Range("A" & Rows.Count).End(xlUp).Offset(-1)).Resize(, 7)
    
    sourceRNG.Copy
    With tempWS
        .Cells(1).PasteSpecial (xlPasteFormats)
        .Cells(1).PasteSpecial (xlPasteValues)
        sourceWB.Close False
        .Columns("D:D").Insert Shift:=xlToRight
        .Columns("C:D").Insert Shift:=xlToRight
        .Cells(1).Resize(tempWS.Range("A" & Rows.Count).End(xlUp).Row, 10).Copy targetWS.Range("A" & Rows.Count).End(xlUp).Offset(1)
    End With
    
    With Application
        .DisplayAlerts = False
            tempWS.Delete
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

    targetWS.Activate
    targetWB.Save
End Sub

 

[shknbk2]

lr needs to have 1 subtracted from it because you don't want the last row.
lastr needs to have 1 added to it because you want to put the data in the next available row

In the code below, you need to modify where the Destination ranges of each column of the SourceWB is to be copied in the TargetWB. Your tables for TargetWB were not clear using the lowercase letters.

Sub CopySource()
    Dim SourceWB As Workbook: Set SourceWB = Workbooks("Source File.xlsx")
    Dim TargetWB As Workbook: Set TargetWB = Workbooks("Target File.xlsm")
    Dim lr As Long: lr = SourceWB.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row - 1
    Dim lastr As Long: lastr = TargetWB.Sheets("Final").Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    SourceWB.Sheets("Sheet1").Range("A1:A" & lr).Copy Destination:=TargetWB.Sheets("Final").Range("A" & lastr)
    SourceWB.Sheets("Sheet1").Range("B1:B" & lr).Copy Destination:=TargetWB.Sheets("Final").Range("B" & lastr)
    SourceWB.Sheets("Sheet1").Range("C1:C" & lr).Copy Destination:=TargetWB.Sheets("Final").Range("C" & lastr)
    SourceWB.Sheets("Sheet1").Range("D1:D" & lr).Copy Destination:=TargetWB.Sheets("Final").Range("D" & lastr)
    SourceWB.Sheets("Sheet1").Range("E1:E" & lr).Copy Destination:=TargetWB.Sheets("Final").Range("E" & lastr)
    SourceWB.Sheets("Sheet1").Range("F1:F" & lr).Copy Destination:=TargetWB.Sheets("Final").Range("F" & lastr)
    SourceWB.Sheets("Sheet1").Range("G1:G" & lr).Copy Destination:=TargetWB.Sheets("Final").Range("G" & lastr)
End Sub

If this doesn't give you the results you need, see if you can modify it. Otherwise, provide a little more detail about where the data values are on each of the sheets (Source data starts in cell A1, Target data needs to be copied to columns A, C, D, F, etc.)

 

[whoosh]

WOW. Thanks to both Yongle and shknbk2.
Both codes work on my temp files!

For Yongle's code
Nice when I don't have to open the source file. But the actual scenario, I'm getting updated file every week for updating, filename will be the same but will be stored in a different folder (with reference to the date) for archive purposes. So there will be extra steps to either change the code or copy the file into a common folder to make it work.

For shknbk2's code
Code is easier for me to understand and digest. As mentioned, it works perfectly on my template but when I apply it on the actual workbook it gave me an error which I cannot comprehend.

Run-time error "1004"
Application-defined or object-defined error
​

and this was highlighted:

Dim lr As Long: lr = sourceWB.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row - 1
​

I thought it could be a typo error, but when i created a black workbook with the same name it works!
Any idea what could be the root cause?

 

[shknbk2]

Not sure of the root cause, but looking at the code now, maybe there was something with the Rows.Count part.

It may not matter in the end because worksheets would tend to have the same number of rows, but that Rows.Count is probably coming from the activeSheet of the current workbook, not the number of rows in Sheet1 of the SourceWB file. Again, that number should be somewhat the same, so it may not be the problem. But, a more complete version would be:

[COLOR=#333333]lr = SourceWB.Sheets("Sheet1").Cells([/COLOR][COLOR=#333333]SourceWB.Sheets("Sheet1").[/COLOR][COLOR=#333333]Rows.Count, "A").End(xlUp).Row - 1[/COLOR]

Same thing for the TargetWB lastr.

 

[whoosh]

Well, it got rid of the initial error. But stop again at "Copy method of Range class failed"

sourceWB.Sheets("Sheet1").Range("A2:A" & lr).Copy Destination:=targetWB.Sheets("FRBO").Range("A" & lastr)
​

Strangely enough, data from Source - column A was copied over.

 

[shknbk2]

When it stopped, what was the value of lr? If you're starting with A2 and A2 is the only row, the error will probably occur because lr would be 1 (2 being the row found with End(xlUp) and then 1 being subtracted therefrom), so "A2:A1" is probably frowned upon.

 

[whoosh]

When it stopped, what was the value of lr? If you're starting with A2 and A2 is the only row, the error will probably occur because lr would be 1 (2 being the row found with End(xlUp) and then 1 being subtracted therefrom), so "A2:A1" is probably frowned upon.

I am lost. You mean the last row of the data in the source file? Last row is 241.
When copying the data it should start from A2, cause row 1 is the header.

 

[shknbk2]

That is what I meant. Ok. 241 rows. Not sure why the error occurred.

 

[Yongle]

For Yongle's code
Nice when I don't have to open the source file. But the actual scenario, I'm getting updated file every week for updating, filename will be the same but will be stored in a different folder (with reference to the date) for archive purposes. So there will be extra steps to either change the code or copy the file into a common folder to make it work.

the code could be modified to
either
- allow user to navigate to correct file
or
- let VBA determine the folder based on week number provided by user
(add input box or get from cell in worksheet, requires "rule" to generate folder path)
or
- use your present method with both files open at the start