I would like to
Loop through all excel files in a folder "\xxxx\INPUT\File1.xlsm".
Copy a particular sheet "Template".
Paste the "Template" sheet into another file "\xxxx\TEMPLATE\WEBADI.xlsm".
Rename file WEBADI.xlsm as File1_WEBADI and save it in folder "\xxxx\OUTPUT\File1_WEBADI.xlsm
Below is the VBA code I worked on.
It executes fine until the step where it copies the sheet "Template" to the WEBADI.xlsm
Once the sheet is copied the VBA code exits execution without any error.
Sub CpyRebateADI()
Dim myPath As String
Dim OutputPath As String
Dim myExtension As String
Dim myFile As String
Dim wb As Workbook
Dim ws As Worksheet
Dim wb1 As Workbook, Wb2 As Workbook, wb3 As Workbook
Set wb1 = ActiveWorkbook
myPath = "\\XXXX\INPUT\"
OutputPath = "\\XXXX\OUTPUT\"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
On Error GoTo ErrHandler
previousSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myExtension = "*.xl*"
myFile = Dir(myPath & myExtension)
Do While myFile <> ""
Application.DisplayAlerts = False
Debug.Print (myFile)
filestr1 = "\\XXXX\TEMPLATE\WEBADI.xlsm"
Set wb3 = Workbooks.Open(filestr1, UpdateLinks:=False)
Set Wb2 = Workbooks.Open(filename:=myPath & myFile, UpdateLinks:=False)
Dim source_worksheet As Worksheet
Set source_worksheet = Wb2.Worksheets("Template")
source_worksheet.Visible = True
Dim target_worksheet As Worksheet
Set target_worksheet = wb3.Worksheets("WebADI")
source_worksheet.Copy After:=target_worksheet
'This is where the macro stops executing
wb3.SaveAs filename:=OutputPath & myFile & "_WebADI", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Wb2.Close SaveChanges:=False
myFile = Dir
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.AutomationSecurity = previousSecurity
ErrHandler:
MsgBox Err.Description, vbExclamation
End Sub
Related
I have a workbook with filtered ranges on each sheet. I have tried a couple different methods but when stepping through it only does the first sheet or none at all. This is what I have tried.
dim ws as worksheet
For Each Ws In ThisWorkbook.Worksheets
If Ws.AutoFilterMode Then
Ws.AutoFilter.ShowAllData
End If
Next Ws
this one isn't doing anything at all
this one is less sophisticated and not what I want.
For Each ws In ThisWorkbook.Worksheets
Rows("1:1").Select
Selection.AutoFilter
Next ws
this is only doing the first worksheet and not moving to the next.
this is the full code and it is not returning any errors
Sub Cleanup()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim mergedWb As Workbook
Set mergedWb = Workbooks.Add()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim ws As Worksheet
Application.ScreenUpdating = False
FolderPath = "<folder path>"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
For Each Sheet In wb.Sheets
Sheet.Copy After:=mergedWb.Sheets(1)
Next Sheet
wb.Close
Filename = Dir()
Loop
Sheets(1).Delete
For Each ws In ThisWorkbook.Worksheets
If ws.AutoFilterMode Then
ws.AutoFilter.ShowAllData
End If
Next ws
End Sub
Copy Sheets to New Workbook
Issues
ThisWorkbook is the workbook containing this code. It has nothing to do with the code so far: you're adding a new (destination) workbook (mergedWb) and you're opening (source) files ('wb') whose sheets (Sheet) will be copied. Instead, you should use:
For Each ws In mergedWb.Worksheets
When you use the Sheets collection, you need to keep in mind that it also includes charts. Therefore, you should declare:
Dim Sheet As Object
You need to qualify the first destination (work)sheet to ensure the correct worksheet is deleted:
Application.DisplayAlerts = False ' delete without confirmation
mergedWb.Sheets(1).Delete
Application.DisplayAlerts = True
To turn off the auto filter, you need to use:
dws.AutoFilterMode = False
You can avoid the loop by copying all sheets (that are not very hidden) at once (per workbook):
swb.Sheets.Copy After...
The line swb.Sheets.Copy (no arguments) copies all sheets (that are not very hidden) to a new workbook.
The Code
Option Explicit
Sub Cleanup()
Const SOURCE_FOLDER_PATH As String = "C:\Test"
Const SOURCE_FILE_PATTERN As String = "*.xls*"
If Not CreateObject("Scripting.FileSystemObject") _
.FolderExists(SOURCE_FOLDER_PATH) Then
MsgBox "The folder '" & SOURCE_FOLDER_PATH & "' doesn't exist.", _
vbCritical
Exit Sub
End If
Dim sFolderPath As String: sFolderPath = SOURCE_FOLDER_PATH
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & SOURCE_FILE_PATTERN)
If Len(sFileName) = 0 Then
MsgBox "No files found."
Exit Sub
End If
Dim swb As Workbook
Dim dwb As Workbook
Dim sFilePath As String
Dim IsNotFirstSourceWorkbook As Boolean
Application.ScreenUpdating = False
Do While Len(sFileName) > 0
sFilePath = sFolderPath & sFileName
Set swb = Workbooks.Open(Filename:=sFilePath, ReadOnly:=True)
If IsNotFirstSourceWorkbook Then
swb.Sheets.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Else
swb.Sheets.Copy ' creates a new workbook containing the sheets
Set dwb = Workbooks(Workbooks.Count)
IsNotFirstSourceWorkbook = True
End If
swb.Close SaveChanges:=False
sFileName = Dir()
Loop
Dim dws As Worksheet
For Each dws In dwb.Worksheets
If dws.AutoFilterMode Then dws.AutoFilterMode = False
Next dws
' Decide what to do with the new workbook e.g.:
' Application.DisplayAlerts = False ' overwrite without confirmation
' dwb.SaveAs sFolderPath & "CleanUp " & Format(Date, "yyyymmdd")
' Application.DisplayAlerts = True
' dwb.Close SaveChanges:=False ' it has just been saved
Application.ScreenUpdating = True
MsgBox "Cleaned up.", vbInformation
End Sub
I have a macro excel file that does some clean up on cells and I need to import a single sheet from various files on the same folder. For example I need the sheet1 from all the excel files located on the same folder as my macro file. I have a code to do that manually but I need to be able to do it automatically either by selecting the files or running another macro to select them no matter the amount of files on the folder.
Sub Carga_Masiva()
Dim fName As String, wb As Workbook
fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
Exit For
End If
Next
wb.Close False
End Sub
I'd prompt user for a folder and then iterate over each file except the one with your macro.
To prompt for a folder use this solution (in my code as optional variant): link
Complete code below:
Sub Carga_Masiva()
Dim sh As Worksheet
Dim fName As String, wb As Workbook
fName = Application.GetOpenfnamename("Excel fnames (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
Exit For
End If
Next
wb.Close False
End Sub
Sub CopyToThisWorkbook()
Dim wbMacro, wb As Workbook
Set wbMacro = ThisWorkbook
Dim sh As Worksheet
Dim folderPath, fName, tabName As String
folderPath = wbMacro.Path & Application.PathSeparator
'Prompt variant
'folderPath = GetFolder & Application.PathSeparator
fName = Dir(PathName:=folderPath)
Do
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Open all files except the one with macro
If fName <> wbMacro.Name Then
'Your code
Set wb = Workbooks.Open(wbMacro.Path & "\" & fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
tabName = sh.Name & "_" & Right(wb.Name, 10) 'Optional - rename Worksheet to be copied
sh.Name = tabName 'Optional
sh.Copy Before:=wbMacro.Sheets(1)
Exit For
End If
Next sh
wb.Close SaveChanges:=False
End If
fName = Dir
Loop Until fName = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function GetFolder() As String 'Optional variant
Dim fldr As fnameDialog
Dim sItem As String
Set fldr = Application.fnameDialog(msofnameDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialfnameName = Application.DefaultfnamePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
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
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
I have written the following code in VBA. When debugging, I am not able to find any problems. It is not creating nor converting any file into .CSV.
Sub SaveToCSVs()
Dim fDir As String
Dim Wb As Workbook
Dim wS As Worksheet
Dim csvWs As String, csvWb As String
Dim extFlag As Long '0 = .xls & 1 = .xlsx extension types
Dim fPath As String
Dim sPath As String, dd() As String
fPath = "C:\Users\DA00358662\Documents\XLSCONV\*.*"
sPath = "C:\Users\DA00358662\Documents\XLSCONV\"
fDir = Dir(fPath)
extFlag = 2
Do While (fDir <> "")
If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then
extFlag = 0
Else
extFlag = 2
End If
On Error Resume Next
If extFlag = 0 Then
fDir = Dir
Set Wb = Workbooks.Open(fPath & fDir)
csvWb = Wb.Name
dd = Split(csvWb, ".")
For Each wS In Wb.Sheets
wS.SaveAs dd(0) & wS.Name & ".csv", xlCSV
Next wS
Wb.Close False
Set Wb = Nothing
fDir = Dir
On Error GoTo 0
End If
Loop
End Sub
with this code (standard for my use) you can find that you need (modify as your need).
In short the code ask which directory to loop and for each file, with the corresponding extension, in this directory it open file, save as csv in the some directory, and close the original file.
Sub SaveAsCsv()
Dim wb As Workbook
Dim sh As Worksheet
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 Exit Sub
'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)
nameWb = myPath & Left(myFile, InStr(1, myFile, ".") - 1) & ".csv"
ActiveWorkbook.SaveAs Filename:=nameWb, FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
'Get next file name
myFile = Dir
Loop
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
The Moment you concatenate fPath and fDir to open your Workbook, you get something like:
"C:\Users\DA00358662\Documents\XLSCONV\*.*MyWorkbook.xls"
Note *.* in the middle ruining your day. I think you want to use sPath here?