I have a macro that I partly created and pieced together from other codes. The intent of the the macro is to search all Excel files in my desktop folder called Financials -- it has approximately 25 files -- and to copy and paste into a new document all Worksheets that have the word (State) anywhere in the name; combine those Worksheets into 1 document and save the it my desktop folder called Final.
The code only saves a blank document to my folder and doesn't execute the other code
I have tried rearranging the code sequence
Sub CombineState()
Dim wbOpen As Workbook
Dim wbNew As Workbook
Const strPath As String = "C:\Users\johnson\Desktop\Financials"
Dim strExtension As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
strExtension = Dir("*.xlsx")
Set wbNew = Workbooks.Add
wbNew.SaveAs Filename:="C:\Users\johnson\Desktop\Final\Financial Metrics for State", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
Dim checkSheet As Worksheet
For Each checkSheet In wbOpen.Worksheets
If UCase$(checkSheet.Name) Like "*State*" Then
checkSheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
End If
Next
wbOpen.Close SaveChanges:=False
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Hypothetically speaking, if 3 documents contain State anywhere in the worksheet name, the new document will have 3 worksheets and be saved to my Final folder.
You were close. See the comment:
Sub CombineState()
Dim wbOpen As Workbook
Dim wbNew As Workbook
Const strPath As String = "C:\Users\johnson\Desktop\Financials\" ' Add the backslash at the end
Dim strExtension As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
strExtension = Dir("*.xlsx")
Set wbNew = Workbooks.Add
wbNew.SaveAs Filename:="C:\Users\johnson\Desktop\Final\Financial Metrics for State", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
Dim checkSheet As Worksheet
For Each checkSheet In wbOpen.Worksheets
If UCase$(checkSheet.Name) Like "*STATE*" Then
checkSheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
End If
Next
wbOpen.Close SaveChanges:=False
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Related
I am working on this codes, but can't make it work.
Here is my working code:
Sub AREA21()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim regFile As String
Dim myExtension As String
Dim RegX As String
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ThisWorkbook.UpdateLinks = xlUpdateLinksNever
myPath = "C:\Users\Aspire E 14\Desktop\xx\xxx\"
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*area trees yield of NFICCs in *.xls*"
RegX = "*area trees yield of NFICCs in REG*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
regFile = Dir(RegX & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
If myFile = regFile Then GoTo skipRegFile
Set wb = Workbooks.Open(Filename:=myPath & myFile, UpdateLinks:=False)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'my codes here
For i = 1 To Sheets.Count
Sheets(i).Select
Next i
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
skipRegFile:
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
End Sub
Here is the sample folder:
Files with "REG**" are just the summary of respective provinces.
My goal is to run the codes in provincial files, and skip opening the file if it is a regional summary. However, problems occur when getting the next file in Dir statement as it appears blank.
Still looking for a better work around.
You can adapt this code to suit your needs.
Some suggestions:
Name your variables to something meaningful (sh is hard to understand, sourceRange it's easier)
Indent your code properly (you can use Rubberduckvba.com) to help you with data
Try to break your code into pieces (e.g. first validate, then prepare, then add items)
Comment your code
Code:
Public Sub Area21()
' Basic error handling
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ThisWorkbook.UpdateLinks = xlUpdateLinksNever
' Define files path
Dim filesPath As String
filesPath = "C:\TEMP\"
' Define file name string to match
Dim fileString As String
fileString = "demo"
' Define file name
Dim fileName As String
fileName = Dir(filesPath, vbNormal)
' Loop through files
Do While fileName <> ""
'Set variable equal to opened workbook
If InStr(LCase(fileName), LCase(fileString)) > 0 Then
' Set a reference to the workbook
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Open(fileName:=filesPath & fileName, UpdateLinks:=False)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
' DO SOMETHING WITH THE WORKBOOK
'Save and Close Workbook
targetWorkbook.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
End If
fileName = Dir()
Loop
CleanExit:
' Turn on stuff
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
Exit Sub
CleanFail:
MsgBox "Error " & Err.Description
GoTo CleanExit
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
Add worksheet to workbook using VBA
I am looking to copy an existing (already created worksheet) into about 500 workbooks (*.xlsx) that all reside in the same folder. I was able to cobble together the below code from various other topics on here but I am not able to get it to work.
Private Sub Command0_Click()
Dim file As String
Dim myPath As String
Dim wb As Workbook
Dim rng As Range
Dim wbMaster As Workbook
'if master workbook already opened
'Set wbMaster = Workbooks("ProjectBabelfish.xlsx")
'if master workbook is not opened
Set wbMaster = Workbooks.Open(CurrentProject.Path & "\ProjectBabelfish.xlsx")
Set rng = wbMaster.Sheets("Babelfish").Range("A1:CC200")
myPath = CurrentProject.Path & "\PLOGs\" ' note there is a back slash in the end"
file = Dir(myPath & "*.xlsx*")
While (file <> "")
Set wb = Workbooks.Open(myPath & file)
rng.Copy
With wb.Worksheets("Babelfish").Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
End With
wb.Close SaveChanges:=True
Set wb = Nothing
file = Dir
Wend
Application.CutCopyMode = False
End Sub
Other than simply copying the worksheet from workbook to another, the formulas need to reference cells in the new workbook. Also, I am trying to account for some of the workbooks being locked.
Something like this should work for you:
Sub Command0_Click()
Dim wbMaster As Workbook
Set wbMaster = ThisWorkbook
Dim wsCopy As Worksheet
Set wsCopy = wbMaster.Worksheets("Babelfish")
Dim sFolderPath As String
sFolderPath = wbMaster.Path & "\PLOGs\"
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xlsx")
'Disable screenupdating (to prevent "screen flickering" so macro runs smoother)
'Disable alerts (to suppress "Are you sure?" prompts during worksheet deletion)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Begin loop through files in the folder
Do While Len(sFileName) > 0
Dim sWBOpenPassword As String
Dim sWBProtectPassword As String
Select Case sFileName
'Specify workbook names that require passwords here
Case "Book2.xlsx", "Another Protected File.xlsx", "Third generic password file.xlsx"
sWBOpenPassword = "password"
sWBProtectPassword = "secondpassword"
'If different books require different passwords, can specify additional names with their unique passwords
Case "Book3.xlsx"
sWBOpenPassword = "book3openpassword"
sWBProtectPassword = "book3protectionpassword"
'Keep specifying excel file names and their passwords until completed
Case "Book10.xlsx", "Book257.xlsx"
sWBOpenPassword = "GenericOpenPW2"
sWBProtectPassword = "GenericProtectPW2"
'etc...
'Case Else will handle the remaining workbooks that don't require passwords
Case Else
sWBOpenPassword = ""
sWBProtectPassword = ""
End Select
'Open file using password (if any)
With Workbooks.Open(sFolderPath & sFileName, , , , Password:=sWBOpenPassword)
Dim bProtectedWB As Boolean
bProtectedWB = False 'Reset protected wb check to false
'Check if workbook is protected and if so unprotect it using the specified protection password
If .ProtectStructure = True Then bProtectedWB = True
If bProtectedWB = True Then .Unprotect sWBProtectPassword
On Error Resume Next 'Suppress error if copied worksheet does not yet exist
.Worksheets(wsCopy.Name).Delete 'Delete existing sheet if it exists
On Error GoTo 0 'Remove "On Error Resume Next" condition
wsCopy.Copy After:=.Worksheets(.Worksheets.Count) 'Copy template into the workbook
.Worksheets(wsCopy.Name).Cells.Replace wbMaster.Name, .Name 'Change references from master workbook to current workbook
'If workbook was protected, reprotect it with same protection password
If bProtectedWB = True Then .Protect sWBProtectPassword
'Close file and save the changes
.Close True
End With
sFileName = Dir 'Advance to next file in the folder
Loop
'Re-enable screenupdating and alerts
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I need a macro that will copy tabs from all the files in a folder and combine them into one workbook. I have a current code which will pull the tabs, but they come back blank. I need all the data from the original files to be combined into one file. Is anyone able to help me fix this issue? Thank you in advance.
Sub CreateSheet(worksheetname)
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = worksheetname
End With
End Sub
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
' Insert your code here.
' The following line shows how to reference a sheet within
' the loop by displaying the worksheet name in a dialog box.
CreateSheet (ActiveWorkbook.Worksheets(I).Name)
Next I
End Sub
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
Call WorksheetLoop
'Change First Worksheet's Background Fill Blue
'wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
'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
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Replace your WorksheetLoop procedure with the code below. This will copy each sheet from the referenced (OpenedBook) workbook to ThisWorkbook.
Sub WorksheetLoop(OpenedBook As Workbook)
Dim wrksht As Worksheet
With ThisWorkbook
For Each wrksht In OpenedBook.Worksheets
wrksht.Copy Before:=.Worksheets(.Worksheets.Count)
Next wrksht
End With
End Sub
Change this line of code in the LoopAllExcelFilesInFolder procedure:
Call WorksheetLoop
to
WorksheetLoop wb
If the workbooks you're opening contain code in the open event you may need to add (I know there's a better way than this and I just can't think of it at the moment):
Application.EnableEvents = False
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Application.EnableEvents = True
I don't think you can create a new sheet with a custom name, just the default name. But you can immediately rename it.
Try this:
With ThisWorkbook
set NewSheet = .Sheets.Add(After:=.Sheets(.Sheets.Count))
NewSheet.Name = worksheetname
End With
It is possible to set the parameters in the sub procedure and use the copy command.
Sub WorksheetLoop(WB As Workbook)
Dim WS_Count As Integer
Dim I As Integer
Dim myWB As Workbook
Set myWB = ThisWorkbook
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = WB.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
' Insert your code here.
' The following line shows how to reference a sheet within
' the loop by displaying the worksheet name in a dialog box.
'CreateSheet (ActiveWorkbook.Worksheets(I).Name)
WB.Worksheets(I).Copy after:=myWB.Sheets(myWB.Sheets.Count)
Next I
End Sub
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
WorksheetLoop WB
'Change First Worksheet's Background Fill Blue
'wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
'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
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
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