*URGENT* Merge Multiple Workbook into One and then combine

[Rahulwork]

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

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

 

[sandy666]

Import data from a folder with multiple files (Power Query) - Microsoft Support

Use Excel's Get & Transform (Power Query) experience to combine multiple files, which have the same schema, from a single folder into a single table.

support.microsoft.com

 

[Rahulwork]

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]

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]

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]

very complicated but if you like it ...

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

 

[Rahulwork]

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]

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