Modify VBA code to copy data from Multipile workbooks with multipile sheets

Moe Kadhom

New Member
Joined
Apr 23, 2015
Messages
31
Hi
I was wondering if anyone can help me.
I have below VBA ( that I got from another website) that goes through files in a folder and copy a range from all the first sheets and paste them one after the other in one master sheet. This is working, I just want the code to do this to all the sheets in the files. so copy the range from all sheets and paste them one after the other.


thanks

Code:
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long

 Sub ChDirNet(szPath As String)
 SetCurrentDirectoryA szPath
 End Sub

 Sub Combine_Workbooks_Select_Files()
 Dim MyPath As String
 Dim SourceRcount As Long, Fnum As Long
 Dim mybook As Workbook, BaseWks As Worksheet
 Dim sourceRange As Range, destrange As Range
 Dim rnum As Long, CalcMode As Long
 Dim SaveDriveDir As String
 Dim FName As Variant

 With Application
 CalcMode = .Calculation
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 .EnableEvents = False
 End With

 SaveDriveDir = CurDir
 ChDirNet "C:\"

 FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
 MultiSelect:=True)
 If IsArray(FName) Then
 Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
 rnum = 1
For Fnum = LBound(FName) To UBound(FName)
 Set mybook = Nothing
 On Error Resume Next
Set mybook = Workbooks.Open(FName(Fnum))
 On Error GoTo 0
 If Not mybook Is Nothing Then
 On Error Resume Next
 With mybook.Worksheets(1)
 Set sourceRange = .Range("A1:A25")
 End With
 If Err.Number > 0 Then
 Err.Clear
 Set sourceRange = Nothing
 Else
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
 Set sourceRange = Nothing
 End If
 End If
 On Error GoTo 0

 If Not sourceRange Is Nothing Then

 SourceRcount = sourceRange.Rows.Count

 If rnum + SourceRcount >= BaseWks.Rows.Count Then
 MsgBox "Not enough rows in the sheet. "
BaseWks.Columns.AutoFit
 mybook.Close savechanges:=False
 GoTo ExitTheSub
 Else
 Set destrange = BaseWks.Range("A" & rnum)
 With sourceRange
 Set destrange = destrange. _
 Resize(.Rows.Count, .Columns.Count)
 End With
destrange.Value = sourceRange.Value

 rnum = rnum + SourceRcount
 End If
 End If
 mybook.Close savechanges:=False
 End If
Next Fnum
 BaseWks.Columns.AutoFit
 End If
 ExitTheSub: 
 With Application
 .ScreenUpdating = True
 .EnableEvents = True
 .Calculation = CalcMode
 End With
 ChDirNet SaveDriveDir
 End Sub
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

Forum statistics

Threads
1,214,530
Messages
6,120,071
Members
448,943
Latest member
sharmarick

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