I have zone wise data in different excel. I want to create a macro to merge all excel files in a new worksheet.
I have tried below code but it is not working.
Sub CopyBooks()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Dim destinationWorkbook As Workbook
Set destinationWorkbook = ThisWorkbook
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim sourceWorkbook As Workbook
Dim sourceWorksheet As Worksheet
Const path As String = "C:\Corporate Competition\Excel\merge\"
Dim file As Variant
Dim currentSheets As Long
currentSheets = destinationWorkbook.Sheets.Count
file = Dir(path & "**.xls**")
While file <> ""
Set sourceWorkbook = Workbooks.Open(path & file)
For Each sourceWorksheet In sourceWorkbook.Worksheets
sourceWorksheet.Copy
lCopyLastRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, "A").End(xlUp).Row
lDestLastRow = currentSheets.Cells(ThisWorkbook.Rows.Count, "A").End(xlUp).Offset(1).Row
sourceWorksheet.Range("A2:D" & lCopyLastRow).Copy _
ThisWorkbook.Range("A" & lDestLastRow)
Next
sourceWorkbook.Close savechanges:=False
file = Dir
Wend
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
I want all files to append one after another. Also, a column name to indicate the zone name/excel file name will be of great help.
Related
I need to combine multiple workbook to one workbook.
Source workbooks have unique sheet name = "job"
Destination workbook have multiple sheets name
The Below code have 2 issues,
For loop not work
pasted data in Destination workbook create a new sheet. But i need to paste the data to existing sheet.
Sub combine()
'destination worksheets
Dim Ar As Worksheet
Dim nr As Worksheet
Set Ar = ThisWorkbook.Sheets("sheetAr")
Set nr = ThisWorkbook.Sheets("Sheetnr")
'Source workbooks
Dim FolderPath As String
Dim Filename As String
Application.ScreenUpdating = False
FolderPath = Environ("userprofile" & "\Desktop\Copy")
Filename = Dir(FolderPath & "*.xlsx*")
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
Dim ws As Worksheet
Dim AW As Workbook
Set AW = ActiveWorkbook
Set ws= ActiveWorkbook.Sheets("Job")
For Each AW In ws
AW.Activate
Cells.ShownAll
ws.Copy Ar
Next AW
Workbooks(Filename).Close savechanges = True
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
FolderPath = Environ("userprofile" & "\Desktop\Copy") should be FolderPath = Environ("userprofile") & "\Desktop\Copy\".For Each AW In ws makes no sense since AW is a workbook and ws a worksheet. You probably meant For Each ws in AW but there is no need to loop if only Job sheet is the source. Workbooks(Filename).Close savechanges = True is missing : but since the workbook was opened read-only there are no change to save so use .Close savechanges := False.
Option Explicit
Sub combine()
Dim wb As Workbook, rng As Range
Dim wsAr As Worksheet, wsSrc As Worksheet
Dim FolderPath As String, Filename As String
Dim iTargetRow As Long, c As Long, n As Long
FolderPath = Environ("userprofile") & "\Desktop\Copy\"
Filename = Dir(FolderPath & "*.xlsx*")
' destination worksheet
Set wsAr = ThisWorkbook.Sheets("sheetAr")
iTargetRow = wsAr.UsedRange.Row + wsAr.UsedRange.Rows.Count
Application.ScreenUpdating = False
Do While Filename <> ""
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
Set wsSrc = wb.Sheets("Job")
Set rng = wsSrc.UsedRange
rng.Copy wsAr.Cells(iTargetRow, rng.Column)
iTargetRow = iTargetRow + rng.Rows.Count
wb.Close savechanges:=False ' opened read only
Filename = Dir()
n = n + 1
Loop
Application.ScreenUpdating = True
MsgBox n & " workbooks scanned", vbInformation
End Sub
I've got multiple excel files (.xlsm), which I would like to consolidate into 1 different workbook (just specific range). The range will be always the same, which means that I need to loop through the files in specific folder / folders and copy the range and paste as values into the new workbook.
I've written a script, which I thought that could work, but it does not. It gives me an error message:
Could you advise me what's wrong, please? It gives me the error on this line
x = Sheets("DBC PGB Review").Range("B3:E3").Copy
Or am I completely on a wrong way?
Sub LoopDBCs()
Dim myfolder As String
Dim myfile As String
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("DBCs")
Dim i As Integer
Dim x As Integer
Dim y As Integer
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
myfolder = "F:\REQUIREMENTS\EXCEL\Retrieve DBC Data\DBCs\"
myfile = Dir(myfolder & "*.xlsm")
i = 2
Do While myfile <> ""
Workbooks.Open Filename:=myfolder & myfile, UpdateLinks:=0
x = Sheets("DBC PGB Review").Range("B3:E3").Copy
ActiveWorkbook.Close savechanges:=False
ws.Activate
ws.Range("A:D" & LastRow + 1).PasteSpecial xlPasteValues
i = i + 1
myfile = Dir
Loop
End Sub
Many thanks!
I've avoided ActiveWorkbook or Select as #Zac and #SJR mentioned. I've specified the source and destination workbook and it works fine now. Posting the code for helping others.
Sub LoopDBCs()
Dim myfolder As String
Dim myfile As String
Dim WB As Workbook, ws As Worksheet
Dim WB2
Dim LastRow As Long
Set WB = ThisWorkbook
Set ws = WB.Sheets("DBCs")
Application.ScreenUpdating = False
'setting a path to all DBCs
myfolder = "F:\REQUIREMENTS\EXCEL\Retrieve DBC Data\DBCs\"
myfile = Dir(myfolder & "*.xlsm")
Do While myfile <> ""
'Disabling macro alerts, external links message box
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Set WB2 = Workbooks.Open(Filename:=myfolder & myfile, ReadOnly:=True)
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
'Getting Project ID and Project Name
WB2.Sheets("DBC PGB Review").Range("B3:E3").Copy
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A" & LastRow + 1).PasteSpecial xlPasteValues
WB2.Close savechanges:=False
myfile = Dir
Loop
Application.ScreenUpdating = True
End Sub
I have a folder named "Import" I want to fill up with xls files and import them all at once. The files have the same structure and just require an easy copy and paste to the last cell of my master sheet. With a specific file path it works, but I am not sure how to loop it.
Edit: I tried to implement the Loop. It worked once. After I deleted the data and tried to import them again, I run into 1004 errors, because the Script has a problem with the row "Set UserWorkbook = Application.Workbooks.Open(UserFilename)".
Do I have a logic issue here?
Sub Import_VDL_v2_Button()
'Disable features'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
'Set the target file for import.'
Dim TargetWorkbook As Workbook
Set TargetWorkbook = Application.ActiveWorkbook
'Specifing file directory.'
Dim UserFilename As String
UserFilename = Dir("/Users/Name/Documents/Reporting/Data/Import/" & "*.xls*")
'Start Loop for import.'
Do While Len(UserFilename) > 0
UserFilename = Dir
Dim UserWorkbook As Workbook
Set UserWorkbook = Application.Workbooks.Open(UserFilename)
'Define source and target sheet for copy.'
Dim SourceSheet As Worksheet
Set SourceSheet = UserWorkbook.Worksheets(1)
Dim TargetSheet As Worksheet
Set TargetSheet = TargetWorkbook.Worksheets(1)
'Check for filter and if present, clear all filter in source sheet.'
If SourceSheet.AutoFilterMode = True _
Then SourceSheet.AutoFilter.ShowAllData
'Unhide all rows and columns in source sheet'
SourceSheet.Columns.EntireColumn.Hidden = False
SourceSheet.Rows.EntireRow.Hidden = False
'Copy data from source to last row in target sheet.'
Dim SourceLastRow As Long
SourceLastRow = SourceSheet.Cells(SourceSheet.Rows.Count, "A").End(xlUp).Row
Dim TargetLastRow As Long
TargetLastRow = TargetSheet.Cells(TargetSheet.Rows.Count, "A").End(xlUp).Offset(1).Row
SourceSheet.Range("A2:S" & SourceLastRow).Copy
TargetSheet.Range("A" & TargetLastRow).PasteSpecial xlPasteValues
'Close import file and save active file.'
UserWorkbook.Close
ActiveWorkbook.Save
Loop
'Enable features'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
In this code I am copying data from multiple excel but need those excel file name in master excel in z column. Here I am able to copy the data's but getting error in getting file name. Anyone help me for the same. Have attached the code.
Sub PC()
Dim MyFile As String, MyFiles As String, FilePath As String
Dim t as range
Dim erow As Long
'~~>; Put additional variable declaration
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet
Set extwbk = ThisWorkbook
Set x = extwbk.worksheets("Data").Range("M2:M1048576")
FilePath = InputBox("Enter File Path")
MyFiles = InputBox("Ente File extension with File path")
MyFile = Dir(MyFiles)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'~~> Set your declared variables
Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook
Set wsMaster = wbMaster.Sheets("Data") 'replace Sheet1 to suit
Do While Len(MyFile) > 0
'Debug.Print MyFile
If MyFile <> "Aug-2017.xlsm" Then
Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
Set wsTemp = wbTemp.Sheets(1) 'I used index, you said there is only 1 sheet
'~~> Now directly work on your object
With wsMaster
erow = .Range("A" & .Rows.Count).End(xlUp).Row 'get the last row
wsTemp.Range("N4:X104823").Copy
.Range("A" & erow).Offset(0, 0).PasteSpecial xlPasteValues
x.Offset.value = Activesheet.Name
.Range("M" & erow).offset(0,12).pasteSpecial xlPasteValues
End With
Set wsTemp = Nothing
Set wbTemp = Nothing
End If
'~~> Load the new file
MyFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
so I have about 21 sheets that are all named the exact same across about 16 files. All the formats and such are the exact same, so for example I need to combine all the sheets with "Age" in all 16 files into a master file that will have the "Age" sheet with the aggregated data of all 16 "Age" sheets. Similarly for the other 20 sheet types.
I'm not sure how exactly to do this. I have a macro that currently adds all sheets in a file together into one master workbook, and I'm looking to modify this so it combines similar sheets instead of just adding them all into one workbook.
Any ideas would be appreciated!
Sub AddAllWS()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Documents and Settings\path\to"
Set wbDst = ThisWorkbook
strFilename = Dir(MyPath & "\*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.UsedRange.Copy
wsSrc.Paste (wbSrc.Range("A" & Rows.Count).End(xlUp).Offset(1))
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
You seem to be copying and pasting into the same source worksheet. Check the code below. That might work. I put in comments in the code.
Sub AddAllWS()
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim lLastRow As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbDst = ThisWorkbook
MyPath = "C:\Documents and Settings\path\to\"
strFilename = Dir(MyPath & "*.xls*", vbNormal)
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(MyPath & strFilename)
'loop through each worksheet in the source file
For Each wsSrc In wbSrc.Worksheets
'Find the corresponding worksheet in the destination with the same name as the source
On Error Resume Next
Set wsDst = wbDst.Worksheets(wsSrc.Name)
On Error GoTo 0
If wsDst.Name = wsSrc.Name Then
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
wsSrc.UsedRange.Copy
wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
End If
Next wsSrc
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub