VBA Code to copy data from (specific sheet) in multiple workbooks and paste rows with content to Master Workbook

[clutcher]

The goal is to: write a VBA Code to copy data from (specific sheet) in multiple workbooks and paste rows with content to Master Workbook. I have spent the last few days working on this, but I was really excited to come across this site.

Current, when the information desired is copied, I noticed that it does not paste it within the table I created (using CTL + T), the copied items are displayed at the bottom of the table (1 to 100). For example, if I instruct it to copy and paste it starting on the 5th row on the table, it was pasting the information on line 101 (which is the end of the table i created).
I used 'erow = sheet3.cells(Rows.Count,3).End(xlUp).End(xlUp).Offset(1,0).Row (i.e. with End(xlUp) twice, but this appears to paste the information within the table correctly but does not copy all the rows and paste all the rows from each file.

Below is the code being used, please share your thoughts with me:


"Dim MyFile as String
Dim erow
Dim x as workbook
dim y as workbook
.
.
.
Set x = workbooks.open(MyFile)
set y = Thisworkbook
x.activate
x.sheets("sheet3").Range(C5:AN5).copy
y.activate
erow = sheet3.cells(Rows.Count,3).End(xlUp).Offset(1,0).Row
Activesheet.Paste Destination:=Worksheets("sheet3").Range(Cells(erow,3),cells(erow, 41))
x.close
MyFile = Dir
Loop
End Sub"


The other questions I have are:
a) Is there way to copy the files without opening those files on my computer screen?
b) Is there way to prevent it copying a row/file more than once?
Would greatly appreciate your input.
I owe a lifetime of gratitude to whoever is willing to assist with this.

Note: The Titles and rows are consistent in each of the workbook and the name of the specific sheet I want to copy from is the same in each workbook ....and the name if the sheet being pasted to in the master workbook is the same as well.
Both the workbooks being copied from and pasted master worksheet pasted to ...are password protected.

 

[mumps]

This macro works with the mockup files:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook
    Set wsDest = ThisWorkbook.Sheets("Electric Cars")
    Dim lastRow As Long, ID As Range, foundID As Range
    Const strPath As String = "C:\MyComputer\Documents\Analysis\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        Set wsSource = Sheets("Electric Cars")
        With wsSource.Cells.SpecialCells(xlCellTypeConstants)
            lastRow = .Range("K:K").Cells(.Cells.Count).Row
        End With
        For Each ID In wsSource.Range("K2:K" & lastRow)
            Set foundID = wsDest.Range("K:K").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
            If foundID Is Nothing Then
                With wsDest.Range("K:K").Cells.SpecialCells(xlCellTypeConstants)
                    lastRow = .Cells(.Cells.Count).Row + 1
                End With
                wsSource.Range("A" & ID.Row & ":K" & ID.Row).Copy
                wsDest.Cells(lastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next ID
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

It is hard to tell what is causing the "links" problem. The pivot tables could be causing the problem if they have links that refer to a sheet that no longer exists. Correcting the links may solve the problem.

 

[clutcher]

Big thanks to you Mumps!!! You saved me a lot of time and headache. Made slight changes to error messages by including “UpdateLinks:= False” next to open workbook instruction and updating my advance setting to avoid automated notifications. Truly works and I’m eternally grateful!!! Superman you are ?

 

[mumps]

My pleasure.

 

[clutcher]

Mumps, I want to thank you again for your incredible assistance. The last piece of help is the speed up the system. I included your recommendation above “UpdateLinks:= False” next to open workbook instruction and updating my advance setting to avoid automated notifications", but it's still very slow. It shows 'not responding' for more than 3 minutes before it becomes active again. Any thoughts? The rest of the program is superb!

 

[mumps]

The only thing that I can think of is that you may have formulas in your workbook that are slowing the macro down. If that is the case, this macro will temporarily turn off the calculation of the formulas while the macro runs and then turns calculation back on. Give it a try and see if it helps.

Sub CopyRange()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook
    Set wsDest = ThisWorkbook.Sheets("Electric Cars")
    Dim lastRow As Long, ID As Range, foundID As Range
    Const strPath As String = "C:\MyComputer\Documents\Analysis\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        Set wsSource = Sheets("Electric Cars")
        With wsSource.Cells.SpecialCells(xlCellTypeConstants)
            lastRow = .Range("K:K").Cells(.Cells.Count).Row
        End With
        For Each ID In wsSource.Range("K2:K" & lastRow)
            Set foundID = wsDest.Range("K:K").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
            If foundID Is Nothing Then
                With wsDest.Range("K:K").Cells.SpecialCells(xlCellTypeConstants)
                    lastRow = .Cells(.Cells.Count).Row + 1
                End With
                wsSource.Range("A" & ID.Row & ":K" & ID.Row).Copy
                wsDest.Cells(lastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next ID
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[clutcher]

Thank you!! I tried this solution but it’s still running really slow. Sometimes up to 10 mins. I’ll review my formulas again. If you have other suggestions, please let me know.

The only thing that I can think of is that you may have formulas in your workbook that are slowing the macro down. If that is the case, this macro will temporarily turn off the calculation of the formulas while the macro runs and then turns calculation back on. Give it a try and see if it helps.

Sub CopyRange()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook
    Set wsDest = ThisWorkbook.Sheets("Electric Cars")
    Dim lastRow As Long, ID As Range, foundID As Range
    Const strPath As String = "C:\MyComputer\Documents\Analysis\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        Set wsSource = Sheets("Electric Cars")
        With wsSource.Cells.SpecialCells(xlCellTypeConstants)
            lastRow = .Range("K:K").Cells(.Cells.Count).Row
        End With
        For Each ID In wsSource.Range("K2:K" & lastRow)
            Set foundID = wsDest.Range("K:K").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
            If foundID Is Nothing Then
                With wsDest.Range("K:K").Cells.SpecialCells(xlCellTypeConstants)
                    lastRow = .Cells(.Cells.Count).Row + 1
                End With
                wsSource.Range("A" & ID.Row & ":K" & ID.Row).Copy
                wsDest.Cells(lastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next ID
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Without seeing your actual workbooks, it's hard to test a possible solution. Give this macro a try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook, v1, v2
    Set wsDest = ThisWorkbook.Sheets("Electric Cars")
    v2 = wsDest.Range("K2", wsDest.Range("K" & wsDest.Rows.Count).End(xlUp)).Value
    Const strPath As String = "C:\MyComputer\Documents\Analysis\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        Set wsSource = Sheets("Electric Cars")
        v1 = wsSource.Range("K2", wsSource.Range("K" & wsSource.Rows.Count).End(xlUp)).Value
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(v2)
                If Not .Exists(v2(i)) Then
                    .Add v2(i), Nothing
                End If
            Next i
            For i = 1 To UBound(v1)
                If Not .Exists(v1(i)) Then
                    wsSource.Range("A" & i + 1 & ":K" & i + 1).Copy
                    wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
                End If
            Next i
            .RemoveAll
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[clutcher]

Mumps, you've gone above and beyond ....and I'm still amazed what you're capable of doing. Pardon the delay. I am fully back in the grind now after the holiday break. I tried the latest code you provided. It seems there is an error with one of the lines.

When I tried to debug the code, the problem appears to be with this code:
"Set wkbSource = Workbooks.Open(strPath & strExtension)"

Note: I added .... updatelinks:=False, Password:="test" i.e. "Set wkbSource = Workbooks.Open(strPath & strExtension, updatelinks:=False, Password:="test")

I noticed when I tried running the code, the smallest file in the folder of approximately 22, which is empty opened ...and the code stop working.
The error code appears to be 1004.
May I inquire if UBound needs to be defined? I noticed it was defined upfront. Not sure if CreateObject needs to be defined as well. Thank you so much. I'll provide you prompt update as soon as I hear your recommendation.

 

[mumps]

Do any files open properly? "UBound" doesn't need to be defined. It is a built-in Excel term that refers to the last range variable in the loop. When using the "With" statement, CreateObject doesn't need to be defined.

 

[clutcher]

Mumps: Yes, each of the files open properly. I started using the older code again (i.e.
"Sub CopyRange()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wsDest As Worksheet, wsSource As Worksheet, wkbSource As Workbook
Set wsDest = ThisWorkbook.Sheets("Electric Cars")
Dim lastRow As Long, ID As Range, foundID As Range
Const strPath As String = "C:\MyComputer\Documents\Analysis"
ChDir strPath
strExtension = Dir(strPath & "*.xlsx")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
Set wsSource = Sheets("Electric Cars")
With wsSource.Cells.SpecialCells(xlCellTypeConstants)
lastRow = .Range("K:K").Cells(.Cells.Count).Row
End With
For Each ID In wsSource.Range("K2:K" & lastRow)
Set foundID = wsDest.Range("K:K").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
If foundID Is Nothing Then
With wsDest.Range("K:K").Cells.SpecialCells(xlCellTypeConstants)
lastRow = .Cells(.Cells.Count).Row + 1
End With
wsSource.Range("A" & ID.Row & ":K" & ID.Row).Copy
wsDest.Cells(lastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next ID
wkbSource.Close savechanges:=False
strExtension = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub"

I still love it!! It's runs slightly better or faster now, but noticed the Master file appears to create few lines of empty rows (i.e. the first 7 rows). I have looked into the individual files but couldn't find the source. If you can help solve that problem, I'll be super happy with that. Note, I have 22 files in total including the masterfile. Hope to hear from you soonest.