*URGENT* Merge Multiple Workbook into One and then combine

Rahulwork

Active Member
Joined
Jun 9, 2013
Messages
284
Hello Everyone

I have two workbook in one path and both have same headers.

I have code to merge both the workbook into one but then i need to combine them into one worksheet. like copy data from one sheet to paste on another sheet last filed row

VBA Code:
Sub GetSheets()

Dim Path as Integer

Path = "[F4]"

Filename = Dir(Path & " \" & "*.xls")

Do While Filename <> ""

Workbooks.Open Filename:=Path & Filename, ReadOnly:=True

For Each Sheet In ActiveWorkbook.Sheets

Sheet.Copy After:=ThisWorkbook.Sheets(1)

Next Sheet

Workbooks(Filename).Close

Filename = Dir()

Loop

End Sub
 

Some videos you may like

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

Rahulwork

Active Member
Joined
Jun 9, 2013
Messages
284
Hello

Thank for your response. actually i have so much steps and need to be by code. can u please help me with the PowerQuery code for combine?
 

sandy666

Banned - Rules violations
Joined
Oct 24, 2015
Messages
7,499
Power Query doesn't work with vba so or vba or PQ
if Power Query there is explanation in this link (also scroll down to another link)
 

Rahulwork

Active Member
Joined
Jun 9, 2013
Messages
284

ADVERTISEMENT

Answer

Option Private Module

Sub Ammend_Files()
Dim ultF, ultF2 As Long
Dim ThisBook, PathF, DestF As String
Dim SeekFiles As String
Dim Path As String
Dim Dest As String
Dim Cons As String
Dim Sht0 As String
Dim ShtA, ShtB As String
Dim a As Integer

'Validates Connection
Path = Sheet1.Range("S4")
Dest = Sheet1.Range("S5")
Cons = Sheet1.Range("R5")
If Right(Cons, 1) <> "\" Then Cons = Cons & "\"
SeekFiles = ""
SeekFiles = Dir(Path)
If SeekFiles = "" Then
MsgB = MsgBox("PATH not found", vbExclamation, "XPRO")
Exit Sub
End If
SeekFiles = ""
SeekFiles = Dir(Dest)
If SeekFiles = "" Then
MsgB = MsgBox("DESTINATION not found", vbExclamation, "XPRO")
Exit Sub
End If

'Misc.1
Call Resource_Optimizer_ON

'Declare This WBook Vars
ThisBook = ThisWorkbook.Name
Sht0 = Sheet1.Name

'Open PathF
ThisWorkbook.FollowHyperlink Address:=Path, NewWindow:=True
PathF = ActiveWorkbook.Name
ShtA = Workbooks(PathF).Sheets(1).Name
ultF = Workbooks(PathF).Sheets(ShtA).Cells(Rows.Count, 1).End(xlUp).Row

'Open DestF
ThisWorkbook.FollowHyperlink Address:=Dest, NewWindow:=True
DestF = ActiveWorkbook.Name
ShtB = Workbooks(DestF).Sheets(1).Name
ultF2 = Workbooks(DestF).Sheets(ShtB).Cells(Rows.Count, 1).End(xlUp).Row + 1
If ultF2 < 6 Then ultF2 = 6

'Ammend Data
If ultF >= 6 Then
Workbooks(PathF).Sheets(ShtA).Range("A6:S" & ultF).Copy
Workbooks(DestF).Sheets(ShtB).Select
Workbooks(DestF).Sheets(ShtB).Range("A" & ultF2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If

'Deletes Sheets from Destination
If Workbooks(DestF).Sheets.Count > 1 Then
a = 2
Do While Workbooks(DestF).Sheets.Count > 1
ShtB = Workbooks(DestF).Sheets(a).Name
Workbooks(DestF).Sheets(ShtB).Visible = xlSheetVisible
Workbooks(DestF).Sheets(ShtB).Select
ActiveWindow.SelectedSheets.Delete
Loop
End If

'Close Files
Workbooks(PathF).Close (False)
Workbooks(DestF).Close (True)

'Crea archivo
Cons = Cons & "Consolidated " & DestF & ".xlsx"
Set XlObj = CreateObject("Scripting.FileSystemObject")
On Error GoTo Terminus
XlObj.CopyFile Dest, Cons, True 'Object.CopyFile Source, Destination, File OverWrite(True is default)
On Error GoTo 0

'Misc.2
Call Resource_Optimizer_OFF
MsgB = MsgBox("Operation Successful", vbExclamation, "XPRO")
Exit Sub

Terminus:
Call Resource_Optimizer_OFF
MsgB = MsgBox("An error ocurred copying Destination to Consolidate", vbExclamation, "XPRO")

End Sub
 

sandy666

Banned - Rules violations
Joined
Oct 24, 2015
Messages
7,499
very complicated but if you like it ... :cool: ;)

btw. try to use code tags [CODE] your code here [/CODE]
 
Last edited:

Rahulwork

Active Member
Joined
Jun 9, 2013
Messages
284
Option Private Module

Sub Do_Nothing()

End Sub

Sub Resource_Optimizer_ON()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
End Sub

Sub Resource_Optimizer_OFF()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
'ActiveSheet.DisplayPageBreaks = False
Application.CutCopyMode = False
End Sub
 

sandy666

Banned - Rules violations
Joined
Oct 24, 2015
Messages
7,499
btw. try to use code tags [CODE] your code here [/CODE]
 

Watch MrExcel Video

Forum statistics

Threads
1,123,346
Messages
5,601,087
Members
414,426
Latest member
fraru

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
Top