VBA code to copy paste from multiple workbook to one workbook

kannan10

New Member
Joined
Dec 13, 2021
Messages
6
Office Version
  1. 2016
Platform
  1. Windows
Hello everyone,

I want to copy paste data from multiple workbook to single workbook. I have created sheet names Master Macro and in the sheet3 i have mentioned the names of the files(which is usually our employee names). VBA should go to the folder and fetch data from a sheet named "Rawdata" and should paste it in Master Macro workbook under sheet Rawdata. I have the below code and for some reason i keep getting a Compile error: For Without Next. I am relatively new and this code was given by one of my friend. Kindly help..

Here is the code:


Sub getLdata()

On Error Resume Next


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Sheets("Rawdata").Select
Range("A2:O20000").Select
Selection.ClearContents

For i = 1 To 5
Windows("Master Macro.xlsm").Activate
Sheets("Interface").Select

qname = Sheet3.Range("A" & 1 + i).Value

ChDir "M:\Production Sheet\2021\Dec 2021\"
Workbook.Open Filename:="M:\Production Sheet\2021\Dec 2021\" & quname & ".xlsm", ReadOnly:=True
UpdateLink = False

Application.Calculation = xlCalculationManual

Sheets("Rawdata").Select
Range("A2:O3000").Select
Selection.Copy
Windows("Master Macro.xlsm").Activate
Sheets("Rawdata").Select

testval = Range("A").Value
counter = 2
While testval <> ""
counter = counter + 1
testval = Range("A" & counter).Value
Wend
Range("A" & counter).Select
Selection.PasteSpecial
Paste = xlPasteValues
Operation = xlNone
Skipblanks = False
Transpose = False

Windows(qname & ".xlsm").Activate
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
Workbook(qname & ".xlsm").Close

Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
You have For i = 1 To 5 but not closed with Next
Not sure where you want to put your Next in the code. :)
 
Upvote 0
Check all references and change as required.

Code:
Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
        pth = "C:\Folder One\Folder 2"    '<---- Change required
            For Each c In Sheets("Sheet3").Range("A1:A" & Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row)
                file_Open = Dir(pth & "\" & c.Value & ".xl*")
                    If Dir(pth & "\" & c.Value & ".xl*") <> "" Then
                        Workbooks.Open pth & "\" & file_Open
                            With ActiveWorkbook.Sheets("Rawdata")
                                .UsedRange.Copy ThisWorkbook.Sheets("Rawdata").Cells(ThisWorkbook.Sheets("Rawdata").Rows.Count, 1).End(xlUp).Offset(1)
                            End With
                        Workbooks(file_Open).Close False
                        file_Open = Dir
                    End If
            Next c
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
End Sub
 
Upvote 0
Solution
You have For i = 1 To 5 but not closed with Next
Not sure where you want to put your Next in the code. :)

Hello,

Thank you so much for the input. I shall try and see how it works.

Regards,
Kannan10
 
Upvote 0
Check all references and change as required.

Code:
Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
        pth = "C:\Folder One\Folder 2"    '<---- Change required
            For Each c In Sheets("Sheet3").Range("A1:A" & Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row)
                file_Open = Dir(pth & "\" & c.Value & ".xl*")
                    If Dir(pth & "\" & c.Value & ".xl*") <> "" Then
                        Workbooks.Open pth & "\" & file_Open
                            With ActiveWorkbook.Sheets("Rawdata")
                                .UsedRange.Copy ThisWorkbook.Sheets("Rawdata").Cells(ThisWorkbook.Sheets("Rawdata").Rows.Count, 1).End(xlUp).Offset(1)
                            End With
                        Workbooks(file_Open).Close False
                        file_Open = Dir
                    End If
            Next c
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
End Sub


Thank you for the quick revert. I tried running this code and got an error while running this code. Please check the screenshot...
 

Attachments

  • VBA Code error.jpg
    VBA Code error.jpg
    81 KB · Views: 21
Upvote 0
I don't have a copy of your workbook but as I mentioned, check and change references where required.
Do you have a sheet named "Sheet3" in your Workbook?
Are the names of the files (workbooks) to be copied from in Column A starting at Cell A1?
Hover your mouse pointer over the yellow line and see where it says the culprit is
 
Upvote 0
I don't have a copy of your workbook but as I mentioned, check and change references where required.
Do you have a sheet named "Sheet3" in your Workbook?
Are the names of the files (workbooks) to be copied from in Column A starting at Cell A1?
Hover your mouse pointer over the yellow line and see where it says the culprit is

no the name of the sheet is "Names". Yes the files names to be copied from column A in sheets("Names")

I did the changes and it worked fine.

But i want one change in the code... i want the sheet to copy a particular range like range("A2:O2000"). I tried to add this range there and it is extracting data from a different sheet for some reason.

Below is the altered code i used. if you could help me with this minor correction, this should solve my problem.

Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
pth = "\\192.168.100.8\share\Production Sheet\2021\Dec 2021\"
For Each c In Sheets("Names").Range("A1:A" & Sheets("Names").Cells(Rows.Count, 1).End(xlUp).Row)
file_Open = Dir(pth & "\" & c.Value & ".xl*")
If Dir(pth & "\" & c.Value & ".xl*") <> "" Then
Workbooks.Open pth & "\" & file_Open
With ActiveWorkbook.Sheets("Rawdata")
.UsedRange.Copy.Copy ThisWorkbook.Sheets("Rawdata").Cells(ThisWorkbook.Sheets("Rawdata").Rows.Count, 1).End(xlUp).Offset(1)
End With
Workbooks(file_Open).Close False
file_Open = Dir
End If
Next c
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
 
Upvote 0
no the name of the sheet is "Names". Yes the files names to be copied from column A in sheets("Names")

I did the changes and it worked fine.

But i want one change in the code... i want the sheet to copy a particular range like range("A2:O2000"). I tried to add this range there and it is extracting data from a different sheet for some reason.

Below is the altered code i used. if you could help me with this minor correction, this should solve my problem.

Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
pth = "\\192.168.100.8\share\Production Sheet\2021\Dec 2021\"
For Each c In Sheets("Names").Range("A1:A" & Sheets("Names").Cells(Rows.Count, 1).End(xlUp).Row)
file_Open = Dir(pth & "\" & c.Value & ".xl*")
If Dir(pth & "\" & c.Value & ".xl*") <> "" Then
Workbooks.Open pth & "\" & file_Open
With ActiveWorkbook.Sheets("Rawdata")
.UsedRange.Copy.Copy ThisWorkbook.Sheets("Rawdata").Cells(ThisWorkbook.Sheets("Rawdata").Rows.Count, 1).End(xlUp).Offset(1)
End With
Workbooks(file_Open).Close False
file_Open = Dir
End If
Next c
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub


Thank you once again. I figured it out... Now it is working absolutely fine.

thank you so much for your help.. This will save me and my team lot of production time. :)
 
Upvote 0
You have a backslash where there should not be one (pth).

Why 2000 in A2:O2000?
Is that just so that you have enough?
Use a "LastRow" statement, something like
Code:
lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row    'One specific column
'or
lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row    'One specific column
'or
lr = Cells.Find("*", ,xlValues , , xlByRows, xlPrevious).Row     '= Values only, whole sheet
'or
lr = Cells.Find("*", ,xlFormulas , , xlByRows, xlPrevious).Row     '= Includes Formulas, whole sheet

Code:
Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
        pth = "C:\Folder One\Folder 2"    '<---- Change required
        If Not Right(pth, 1) = "\" Then pth = pth & "\"    '<---- Check for backslash
            For Each c In Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row)
                file_Open = Dir(pth & c.Value & ".xl*")
                    If Dir(pth & c.Value & ".xl*") <> "" Then
                        Workbooks.Open pth & file_Open
                            With ActiveWorkbook.Sheets(1)    '<---- Change required
                                .Range("A2:O2000").Copy ThisWorkbook.Sheets(3).Cells(ThisWorkbook.Sheets(3).Rows.Count, 1).End(xlUp).Offset(1)    '<---- Change required
                            End With
                        Workbooks(file_Open).Close False
                        file_Open = Dir
                    End If
            Next c
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
End Sub

Oh, and BTW

Use Code Tags MrExcel.JPG
 
Upvote 0
You have a backslash where there should not be one (pth).

Why 2000 in A2:O2000?
Is that just so that you have enough?
Use a "LastRow" statement, something like
Code:
lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row    'One specific column
'or
lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row    'One specific column
'or
lr = Cells.Find("*", ,xlValues , , xlByRows, xlPrevious).Row     '= Values only, whole sheet
'or
lr = Cells.Find("*", ,xlFormulas , , xlByRows, xlPrevious).Row     '= Includes Formulas, whole sheet

Code:
Sub Maybe_So()
Dim file_Open As String, c As Range, pth As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
        pth = "C:\Folder One\Folder 2"    '<---- Change required
        If Not Right(pth, 1) = "\" Then pth = pth & "\"    '<---- Check for backslash
            For Each c In Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row)
                file_Open = Dir(pth & c.Value & ".xl*")
                    If Dir(pth & c.Value & ".xl*") <> "" Then
                        Workbooks.Open pth & file_Open
                            With ActiveWorkbook.Sheets(1)    '<---- Change required
                                .Range("A2:O2000").Copy ThisWorkbook.Sheets(3).Cells(ThisWorkbook.Sheets(3).Rows.Count, 1).End(xlUp).Offset(1)    '<---- Change required
                            End With
                        Workbooks(file_Open).Close False
                        file_Open = Dir
                    End If
            Next c
    .DisplayAlerts = True
    .ScreenUpdating = True
  End With
End Sub

Oh, and BTW

View attachment 53359
Thank you so much... Worked absolutely fine.. I am sure i will implement these logics in many of my reports. :)
 
Upvote 0

Forum statistics

Threads
1,213,483
Messages
6,113,919
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top