Combine multiple workbooks to one workbook in same folder

Muhammad Hussaan

New Member
Joined
Dec 13, 2017
Messages
49
Office Version
  1. 2013
Platform
  1. Windows
Hello, I have multiple workbooks in a folder along with main file Name MOM.xlsm to merge data (find code below) I am having some problem with vba code below, it works fine in my computer as path is drive E and folder is "MOM" , i want to make this macro working independent of drive E. So that i can keep in USB storage and make this file workable. Kind suggest what change i should do to make it workable. Below is the codeSub Mergemom()Dim wbk As WorkbookDim sht As WorksheetDim shtt As WorksheetDim sheetfirst As WorksheetDim sheetsecond As WorksheetDim sheetthird As WorksheetDim wbk2 As WorkbookSet wbk2 = ThisWorkbookDim Filename As StringDim Path As StringPath = "E:\MOM" 'CHANGE Folder PATHFilename = Dir(Path & "*.xlsx")'OPEN EXCEL FILESDo While Len(Filename) > 0 'IF NEXT FILE EXISTS THENSet wbk = Workbooks.Open(Path & Filename)wbk.ActivateFor Each shtt In wbk.Worksheetswbk.ActivateVar = shtt.Nameshtt.SelectRange("A2").SelectRange(Selection, Selection.End(xlToRight)).SelectRange(Selection, Selection.End(xlDown)).SelectSelection.CopyWindows("MOM.xlsm").ActivateDim lr As Integer'Var = sht.NameSheets(Var).Selectlr = wbk2.Sheets(Var).Cells(Rows.Count,1).End(xlUp).RowCells(lr + 1, 1).SelectActiveSheet.PasteNextwbk.Close TrueFilename = DirLoopEnd Sub
Code:
Sub Mergemom()
Dim wbk As Workbook
Dim sht As Worksheet
Dim shtt As Worksheet
Dim sheetfirst As Worksheet
Dim sheetsecond As Worksheet
Dim sheetthird As Worksheet
Dim wbk2 As Workbook
Set wbk2 = ThisWorkbook
Dim Filename As String
Dim Path As String
Path = "E:\MOM" 'CHANGE Folder PATH
Filename = Dir(Path & "*.xlsx")
'OPEN EXCEL FILES
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
  Set wbk = Workbooks.Open(Path & Filename)
  wbk.Activate
  For Each shtt In wbk.Worksheets
    wbk.Activate
    Var = shtt.Name
    shtt.Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("MOM.xlsm").Activate
    Dim lr As Integer
    'Var = sht.Name
    Sheets(Var).Select
    lr = wbk2.Sheets(Var).Cells(Rows.Count, 1).End(xlUp).Row
    Cells(lr + 1, 1).Select
    ActiveSheet.Paste
  Next
  wbk.Close True
  Filename = Dir
Loop
End Sub
 
Last edited by a moderator:

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

Forum statistics

Threads
1,213,538
Messages
6,114,218
Members
448,554
Latest member
Gleisner2

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