I have a Master Workbook with several labelled sheets. I am trying to update sheets in this workbooks named: 949, div and active pl.
The data for each of these 3 sheets would be pulled from 3 child workbooks, named accordingly as 949.xlsx, div.xlsx and activepl.xlsx. These workbooks have only 1 sheet in each of them.
How do I clear existing data except the header row then copy all the data from each of the child workbooks (disregarding the first row which is the header), into the respectively named sheets in the Master Workbook?
The macro I have so far:
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Try
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim vName As Variant, vDB As Variant
Dim Master As Workbook, Target As Range
Dim i As Integer
Set Master = ThisWorkbook
vName = Array("949", "div", "activepl")
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
For i = 0 To 2
If InStr(myFile, vName(i)) Then
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
vDB = wb.ActiveSheet.UsedRange.Offset(1)
Master.Sheets(vName(i)).UsedRange.Offset(1).Clear '<~~ Clear cells except head
Set Target = Master.Sheets(vName(i)).Range("b" & Rows.Count).End(xlUp)(2) '<~~ column b
Target.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
End If
Next i
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
You can change the position by giving the condition according to the sheet name.
If vName(i) = "activepl" Then
Master.Sheets(vName(i)).UsedRange.Offset(1, 1).Clear '<~~ Clear cells except head
Set Target = Master.Sheets(vName(i)).Range("b" & Rows.Count).End(xlUp)(2) '<~~ column b
Else
Master.Sheets(vName(i)).UsedRange.Offset(1).Clear '<~~ Clear cells except head
Set Target = Master.Sheets(vName(i)).Range("a" & Rows.Count).End(xlUp)(2) '<~~ column b
End If
Edition
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim vName As Variant, vDB As Variant
Dim Master As Workbook, Target As Range
Dim i As Integer
Set Master = ThisWorkbook
vName = Array("949", "div", "activepl")
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
For i = 0 To 2
If InStr(myFile, vName(i)) Then
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
vDB = wb.ActiveSheet.UsedRange.Offset(1)
If vName(i) = "activepl" Then
Master.Sheets(vName(i)).UsedRange.Offset(1, 1).Clear '<~~ Clear cells except head
Set Target = Master.Sheets(vName(i)).Range("b" & Rows.Count).End(xlUp)(2) '<~~ column b
Else
Master.Sheets(vName(i)).UsedRange.Offset(1).Clear '<~~ Clear cells except head
Set Target = Master.Sheets(vName(i)).Range("a" & Rows.Count).End(xlUp)(2) '<~~ column b
End If
Target.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
End If
Next i
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
I am using the below code to loop through all workbooks in a chosen folder and change some content in Sheet1 of each workbook. But when the code is finished, the content is successfully changed but all sheets are hidden. Not sure why and how to fix it?
Sub LoopChangeCoreName()
Dim wb, newwb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim i, m As Integer
Dim LR As Long
Dim r As Integer
Dim rng As Range
Dim AuthorName As String
Dim CoreName As String
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
Application.ScreenUpdating = False
'Set variable equal to opened workbook
Set wb = GetObject(myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
If InStr(myFile, "_") > 0 Then AuthorName = Split(myFile, "_")(0)
For m = 2 To wb.Sheets(1).UsedRange.Rows.Count
CoreName = AuthorName & "_" & wb.Sheets(1).Range("A" & m).Value
wb.Sheets(1).Range("A" & m) = CoreName
Next m
DoEvents
'Save and Close Workbook
wb.Sheets(1).Visible = True
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
(repeat only to pass the post check) I am using the below code to loop through all workbooks in a chosen folder and change some content in Sheet1 of each workbook. But when the code is finished, the content is successfully changed but all sheets are hidden. Not sure why and how to fix it? Thank you so much.
I am writing a function that iterates through files in a folder. In each file, iterate through the sheets and save them as CSV files. I tested them without going through the sheets and it works fine. However, when I loop through the sheets, it keeps looping through the files. I ran the debug and found that when it is at the end of the last file, it goes back to the first file. I cannot find what was wrong. Here is my code:
Sub morningstar_VBA()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim filename As String
Dim path_to_save As String
Dim FldrPicker As FileDialog
Dim w As Long
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
For w = 1 To Worksheets.Count
With Worksheets(w).Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
filename = .Worksheets(1).Name
path_to_save = "E:\Morningstar_download\test\" & filename
.SaveAs filename:=path_to_save, FileFormat:=xlCSV
DoEvents
.Close savechanges:=False
End With
End With
Next w
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Maybe try this out :
Sub morningstar_VBA()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim filename As String
Dim path_to_save As String
Dim FldrPicker As FileDialog
Dim w As Long
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(filename:=myPath & myFile)
Windows(wb.Name).Visible = False
'Ensure Workbook has opened before moving on to next line of code
For w = 1 To wb.Worksheets.Count
With wb.Worksheets(w).Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
filename = ActiveWorkbook.Worksheets(1).Name
path_to_save = "E:\Morningstar_download\test\" & filename
wb.SaveAs Filename:="E:\Morningstar_download\test\" & filename & ".csv", FileFormat:=xlCSVWindows
Workbooks( Worksheets(w).Name & ".XLS").Close
End With
Next w
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
i would split this into two parts; mainly because it is easier to handle the code, but also in case you need parts of the code in other circumstances. The sub "Dateien_auswaehlen" can be used to do anything with the choosen files, just by choosing some other routine then morningstar:
Sub Dateien_auswaehlen()
Dim FldrPicker As FileDialog
Dim fso As Object
Dim objFld As Object
Dim objFiles As Object
Dim file
Dim myPath As String
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFld = fso.GetFolder(myPath)
Set objFiles = objFld.Files
For Each file In objFiles
'here any sub can be called for working with the files found:
If LCase(file.Name) Like myExtension Then Call morningstar_VBA(myPath, file.Name)
Next
'Message Box when tasks are completed
MsgBox "Task Complete!"
Set fso = Nothing
Set objFld = Nothing
Set objFiles = Nothing
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub morningstar_VBA(path As String, filename As String)
Dim wb As Workbook
Dim myFile As String
Dim myExtension As String
Dim path_to_save As String
Dim w As Long
Set wb = Workbooks.Open(path & filename)
'Ensure Workbook has opened before moving on to next line of code
For w = 1 To Worksheets.Count
With Worksheets(w).Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
filename = .Worksheets(1).Name
path_to_save = "E:\Morningstar_download\test\" & filename
.SaveAs filename:=path_to_save, FileFormat:=xlCSV
DoEvents
.Close savechanges:=False
End With
End With
Next w
wb.Close savechanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
End Sub
Hi i have this code that counts the number of time "T" appears in the various workbooks where each workbook have around 10-12 sheets. the main objective is to have the final workbook get the the total number of times T appeared as it loops through the file.
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim x As Integer
Dim wash_count As Integer
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For Each ws In wb.Sheets
If ws.Name <> "Summary" Then
For x = 5 To 74
If StrConv(ws.Cells(x, 2).Value, vbProperCase) = "Wash" And StrConv(ws.Cells(x, 4).Value, vbProperCase) = "T" Then 'added the StrConv to make sure you don't loose a case just because it was written in capital or lowercase letters
wash_count = wash_count + 1
End If
Next x
End If
Next ws
Sheets("Summary").Range("D6") = wash_count
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The problem now is that the previous workbooks with the sheets also named "Summary" gets the counter input inside it too.
right now the code gets the final count in the last workbook, but how do i avoid having it appear in the summary pages in the previous workbooks, i want to direct all the counts only to the final workbook.
Thanks in advance
You can do something like this:
Dim ColFiles As New Collection, i As Long
'...
'...
'...
'collect the files first
myFile = Dir(myPath & myExtension)
Do While myFile <> ""
ColFiles.Add myPath & myFile
myFile = Dir()
Loop
'now loop over the collection
For i = 1 To ColFiles.Count
Set wb = Workbooks.Open(ColFiles(i))
'count things in wb
'is this the last file?
If i = ColFiles.Count Then
wb.Sheets("Summary").Range("D6") = wash_count
wb.Close True 'save
Else
wb.Close False 'no save
End If
Next i
I'm new to VBA. I've been using for loop to add counts to my summary page, but as it loops through the multiple workbooks, the summary page keeps increasing as it adds up the value of the previous workbook too.
How do I specify the counter to just count and add into their specific summary page?
E.g. first workbook summary page count is 10, the next workbook workbook will be 10+ that workbook's count. Thanks in advance!
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim x As Integer
Dim wash_count As Integer
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
For Each ws In wb.Sheets
If ws.Name <> "Summary" Then
For x = 5 To 74
If ws.Cells(x, 2).Value = "Wash" And (ws.Cells(x, 4).Value = "T") Then
wash_count = wash_count + 1
End If
Next x
End If
Next ws
wb.Sheets("Summary").Range("D6") = wash_count
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
You're not resetting your counter:
'...
wb.Sheets("Summary").Range("D6") = wash_count
wash_count = 0 '<< reset for next workbook
I am trying to copy Range(A14:L26) from all closed workbooks in a file on my desktop. The data should be pasted in a master workbook, which is my current workbook.
Also only the values and not the formula or formatting should be pasted. So basically only what is visible in the cells should be pasted.
The values should be pasted in a table in order for them to be visualized later.
When running the code I get the notification that Excel can't access the files in the folder on my desktop as they might be protected.
How can I "unprotect" them via VBA so I can copy the data.
Any help on this would be very much appreciated!
Option Explicit
Sub CopySpecialPaste()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim ws2 As Worksheet
Dim y As Workbook
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Choose Target Folder Path"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xlsm*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set y = Workbooks.Open("C:\Users\XXX")
Set ws2 = y.Sheets("Important Information")
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Copy data on "Important Information" sheet to "Evaluation" Sheet in
other workbook
With wb.Sheets("Important Information")
If WorksheetFunction.CountA(wb.Sheets("Important _
Information").Range("A14:L26")) <> 0 Then
lRow = .Range("L" & Rows.Count).End(xlUp).Row 'not sure which Range to
'add here
wb.Sheets("Important Information").Range("A14:L26" & lRow).Copy
ws2.Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial
Paste:=xlPasteValues
Application.CutCopyMode = False
Else
End If
End With
wb.Close SaveChanges:=False
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "I hope that worked!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub