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
Related
The code I have below does more or less that what title says but every time it reads one file creates a new worksheet and pastes the content there
Code
Sub fileLoop()
Dim mypath As String, myfile As String
mypath = "C:\Users\xxxx\Desktop\test macro\"
myfile = Dir(mypath & "*.xlsx")
Dim ws As Worksheet
Do While myfile <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(mypath & myfile)
Set ws = wb.Sheets(1)
For Each ws In wb.Worksheets
ws.Copy after:=ThisWorkbook.ActiveSheet
Next
wb.Close
myfile = Dir
Loop
End Sub
Files I have
What I get
What I need
I tried changing this line to get the content of files in the same worksheet
For Each ws In wb.Worksheets
ws.Copy after:=ThisWorkbook.ActiveSheet
Next
Change ws.Copy after:=ThisWorkbook.ActiveSheet
To ws.UsedRange.Copy ActiveSheet.Cells(ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1,1)
Also the Set ws = wb.Sheets(1) is useless because you are just resetting it without use in the very next statement!
Try playing around with this:
Option Explicit
Sub fileLoop()
Dim mypath As String, myfile As String
mypath = "C:\Users\xxxx\Desktop\test macro\"
myfile = Dir(mypath & "*.xlsx")
Dim ws As Worksheet
Dim wb As Workbook
Dim rngTarget As Range
Dim numRows As Integer
Set rngTarget = ThisWorkbook.Worksheets("Hoja1").Range("A2:M2")
Do While myfile <> ""
Set wb = Workbooks.Open(mypath & myfile)
For Each ws In wb.Worksheets
numRows = ws.Range("A1").Offset(Rows.Count - 1).End(xlUp).Row
rngTarget.Resize(numRows).Value = ws.Range("A2:M2").Resize(numRows).Value
Set rngTarget = rngTarget.Offset(numRows)
Next ws
wb.Close
myfile = Dir
Loop
Set rngTarget = Nothing
Set wb = Nothing
End Sub
Hi I have the following code which loops through dropdown selections and saves each result as a new workbook based on the named range in cell G3. I am trying to edit the code so that it saves all the worksheets to the new file instead of just the active one, if anyone could help? thank you
Sub myFiles()
Dim wb As Workbook
Dim ws As Worksheet
Dim nwb As Workbook
Dim nws As Worksheet
Dim rng As Range
Dim Path As String
Dim myDate As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
Path = "C:\Users\bradley\Desktop\Sales by Month\"
myDate = Format(Now(), "MM-DD-YYYY")
For i = 1 To 4
rng = ws.Range("J" & i)
ws.Copy
Set nwb = ActiveWorkbook
Set nws = nwb.Worksheets("Summary")
With nws
Cells.Copy
Cells.PasteSpecial (xlPasteValues)
End With
Application.DisplayAlerts = False
nwb.SaveAs FileName:=Path & rng & " " & myDate & ".xlsx",
FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
End Sub
Loop through the sheets but only create a workbook on the first one.
Option Explicit
Sub myFiles()
Const FOLDER = "C:\Users\bradley\Desktop\Sales by Month\"
Dim wb As Workbook, nwb As Workbook
Dim ws As Worksheet, rng As Range
Dim myDate As String, i As Long, j As Long
Dim filename As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
myDate = Format(Now(), "MM-DD-YYYY")
Application.ScreenUpdating = False
For i = 1 To 4
rng.Value2 = ws.Range("J" & i).Value2
' copy all sheets
For j = 1 To wb.Sheets.Count
If j = 1 Then
wb.Sheets(j).Copy
Set nwb = ActiveWorkbook
Else
wb.Sheets(j).Copy after:=nwb.Sheets(j - 1)
End If
With nwb.Sheets(j)
.UsedRange.Value2 = .UsedRange.Value2
End With
Next
' save workbook
filename = FOLDER & rng.Value2 & " " & myDate & ".xlsx"
Application.DisplayAlerts = False
nwb.SaveAs filename:=filename, FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
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
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