I currently have the following code. Currently this code will loop through a folder of excel files and will open them and then save them in that folder, but I can't get the code to then take those files flatten them and then place them into another folder. Any advice?
Sub ALoopFile()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False
Dim MyFolder As String
Dim MyFile As String
Dim SendTo As String
Dim SendFile As String
Dim CurrentWB As Workbook 'Workbook Stores Workbook
MyFolder = "Y:\Dropbox (Efficiency3)\Monthly Projects\001 - AU"
MyFile = Dir(MyFolder & "\*.xls")
SendTo = "Y:\Dropbox (Efficiency3)\Monthly Projects\001 - AU\Flattened_Files"
SendFile = Dir(SendTo & "\*.xls")
Do While MyFile <> ""
Set CurrentWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=3) 'Sets CurrentWB = to that long name. This becomes the name of the workbook.
CurrentWB.RunAutoMacros Which:=xlAutoOpen 'Enables Macros in Workbook
CurrentWB.SaveAs Filename:=MyFolder & "\" & MyFile, FileFormat:=56
For SheetNumber = 1 To CurrentWB.Sheets.Count 'Counts Worksheets in Workbook
CurrentWB.Sheets(SheetNumber).Select 'Selects All Worksheets in Workbook
If (CurrentWB.Sheets(SheetNumber).Name <> "What If") Then
CurrentWB.Sheets(SheetNumber).Unprotect ("UMC626") 'Unprotects Workbook
Cells.Select 'Selects Data in Workbook
With CurrentWB.Sheets(SheetNumber).UsedRange
.Value = .Value
End With
CurrentWB.Sheets(SheetNumber).Protect Password:="UMC626", DrawingObjects:=True, Contents:=True, Scenarios:=True 'Protects Workbook
End If
Next SheetNumber 'Runs Through Iteration
Sheets(1).Select
Range("A1").Select 'Saves each workbook at the top of the page
CurrentWB.SaveAs Filename:=SendTo & "\" & SendFile, FileFormat:=56, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False 'Saves Workbook in Flatten File Location
CurrentWB.Close 'Closes Workbook
MyFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.PrintCommunication = True
End Sub
I solved the issue by using ThisName = CurrentWB.Name
ALoopFile()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False
Dim MyFolder As String
Dim MyFile As String
Dim SendTo As String
Dim SendFile As String
Dim CurrentWB As Workbook 'Workbook Stores Workbook
MyFolder = "Y:\Dropbox (Efficiency3)\Monthly Projects\001 - AU\"
MyFile = Dir(MyFolder & "\*.xls")
SendTo = "Y:\Dropbox (Efficiency3)\Monthly Projects\001 - AU\Flattened_Files"
SendFile = Dir(SendTo & "\*.xls")
Do While MyFile <> ""
Set CurrentWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=3) 'Sets CurrentWB = to that long name. This becomes the name of the workbook.
CurrentWB.RunAutoMacros Which:=xlAutoOpen 'Enables Macros in Workbook
CurrentWB.SaveAs Filename:=MyFolder & "\" & MyFile, FileFormat:=56
ThisName = CurrentWB.Name
For SheetNumber = 1 To CurrentWB.Sheets.Count 'Counts Worksheets in Workbook
CurrentWB.Sheets(SheetNumber).Select 'Selects All Worksheets in Workbook
If (CurrentWB.Sheets(SheetNumber).Name <> "What If") Then
CurrentWB.Sheets(SheetNumber).Unprotect ("UMC626") 'Unprotects Workbook
Cells.Select 'Selects Data in Workbook
With CurrentWB.Sheets(SheetNumber).UsedRange
.Value = .Value
End With
CurrentWB.Sheets(SheetNumber).Protect Password:="UMC626", DrawingObjects:=True, Contents:=True, Scenarios:=True 'Protects Workbook
End If
Next SheetNumber 'Runs Through Iteration
Sheets(1).Select
Range("A1").Select 'Saves each workbook at the top of the page
CurrentWB.SaveAs Filename:=SendTo & "\" & ThisName
CurrentWB.Close 'Closes Workbook
MyFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.PrintCommunication = True
End Sub
Related
i have a vba code to copy and paste a range of data from multiple excel files in a folder. The sheet that has the data is hidden though. i need to modify my code to copy the hidden sheets range.
Sub Import_to_Master()
Dim sFolder As String
Dim sFile As String
Dim wbD As Workbook, wbS As Workbook
Application.ScreenUpdating = False Set wbS = ThisWorkbook sFolder =
wbS.Path & "\"
sFile = Dir(sFolder) Do While sFile <> ""
If sFile <> wbS.Name Then Set wbD = Workbooks.Open(sFolder & sFile)
'open the file; add condition to
' >>>>>> Adapt this part wbD.Sheets("data").Range("A3:BD3").Copy
wbS.Activate Sheets("data scorecards").Range("A" &
Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False ' >>>>>> wbD.Close savechanges:=True
'close without saving End If
sFile = Dir 'next file Loop Application.ScreenUpdating = True
End Sub
This looks appropriate. I've used direct value transfer instead of copy, paste special, values.
Option Explicit
Sub Import_to_Master()
Dim sFolder As String, sFile As String
Dim wbS As Workbook
Application.ScreenUpdating = False
Set wbS = ThisWorkbook
sFolder = wbS.Path & "\"
sFile = Dir(sFolder & "*.xl*")
Do While sFile <> ""
If sFile <> wbS.Name Then
'open the file; add condition to
With Workbooks.Open(sFolder & sFile)
' >>>>>> Adapt this part wbD
With .Worksheets("data").Range("A3:BD3")
wbS.Worksheets("data scorecards").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
End With
'close without saving
.Close savechanges:=False
End With
End If
sFile = Dir 'next file
Loop
Application.ScreenUpdating = True
End Sub
I have the following VBA code saving workbook1 sheets to a folder where workbook1 file is saved. Example: workbook1 has 31 sheets. The code saves each sheet to a new workbook with the same name as the sheet. (Sheet1, Sheet2, etc).
Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
I need to modify the code to save the file with the ID and date. The ID is in cell A1. "XXX Clinic Pro Fees Report for Doe, John (JDOE)". In this example I need the new workbook to save as JDOE_2017-10-20.
Is there a way to gave the ID and place the date after it?
Try the below code
Sub SaveShtsAsBook()
Dim ldate As String
Dim SheetName1 As String
ldate = Format(Now(), "yyyy-mm-dd")
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
SheetName1 = Range(A1).Value2 & ldate
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
tempstr = Cells(1, 1).Value2
openingParen = InStr(tempstr, "(")
closingParen = InStr(tempstr, ")")
SheetName1 = Mid(tempstr, openingParen + 1, closingParen - openingParen - 1) & "_" & ldate
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName1 & ".xls"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
You can extract the name code from within the brackets and append the date with a couple lines of code.
SheetName = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
SheetName = sn & Format(Date, "_yyyy-mm-dd")
Along with a couple other modifications as,
Option Explicit
Sub SaveShtsAsBook()
Dim ws As Worksheet, sn As String, mfp As String, n As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
On Error Resume Next '<< a folder exists
mfp = ActiveWorkbook.Path & "\" & Split(ThisWorkbook.Name, Chr(46))(0)
MkDir mfp '<< create a folder
On Error GoTo 0 '<< resume default error handling
With ActiveWorkbook
For n = 1 To .Worksheets.Count
With .Worksheets(n)
sn = Split(Split(.Cells(1, 1).Value2, "(")(1), ")")(0)
sn = sn & Format(Date, "_yyyy-mm-dd")
.Copy
With ActiveWorkbook
'save book in this folder
.SaveAs Filename:=mfp & "\" & sn, FileFormat:=xlExcel8
.Close SaveChanges:=False
End With
End With
Next
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
This VBA code is working for me in copying and moving XLS files but when I try to run it on an XLSM file it is telling me runtime error and is highlighting;
"CurrentWB.Sheets(SheetNumber).Select 'Selects All Worksheets in Workbook"
Run-Time Error 1004: Select Method of Worksheet Class Failed
Does anyone know what the issue might be?
Sub AutoUpdate()
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False
Dim SystemPath As String
Dim FilePath As String
Dim FileName As String
Dim UtilityType As String
Dim ThisName As String
Dim FlattenedFilePath As String
Dim FlattenedFileFolder As String
Dim CurrentWB As Workbook 'Workbook Stores Workbook
SystemPath = Range("Sys.Path")
UtilityType = Range("Utility.Type")
FlattenedFileFolder = Range("Flattened.Files")
FilePath = SystemPath & UtilityType
FileName = Dir(FilePath & "\*.xls")
FlattenedFilePath = FilePath & "\" & FlattenedFileFolder
Do While FileName <> ""
Set CurrentWB = Workbooks.Open(FileName:=FilePath & "\" & FileName, UpdateLinks:=3) 'Sets CurrentWB = to that long name. This becomes the name of the workbook.
CurrentWB.RunAutoMacros Which:=xlAutoOpen 'Enables Macros in Workbook
CurrentWB.Save
ThisName = CurrentWB.Name
For SheetNumber = 1 To CurrentWB.Sheets.Count 'Counts Worksheets in Workbook
If (CurrentWB.Sheets(SheetNumber).Name <> "What If") Then
CurrentWB.Sheets(SheetNumber).Unprotect ("UMC626") 'Unprotects Workbook
With CurrentWB.Sheets(SheetNumber).UsedRange
.Value = .Value
End With
CurrentWB.Sheets(SheetNumber).Protect Password:="UMC626", DrawingObjects:=True, Contents:=True, Scenarios:=True 'Protects Workbook
End If
Next SheetNumber 'Runs Through Iteration
CurrentWB.Cells(1, 1).Select 'Saves each workbook at the top of the page
CurrentWB.SaveAs FileName:=FlattenedFilePath & "\" & ThisName
CurrentWB.Close 'Closes Workbook
FileName = Dir
Loop
End Sub
This macro loops through all the files in a directory and formats the data as a table.
I need to sort Column J on the table from Largest to Smallest and then save the file before moving onto the next file. Currently it leaves all the files open.
Sub LoopThroughFiles()
FolderName = "C:\Folder1\"
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
Fname = Dir(FolderName & "*.xls")
'loop through the files
Do While Len(Fname)
With Workbooks.Open(FolderName & Fname)
Dim tbl As ListObject
Dim rng As Range
Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium2"
Columns("A:L").Select
Columns("A:L").EntireColumn.AutoFit
End With
'go to the next file in the folder
Fname = Dir
Loop
End Sub
You are missing the line where you Close the workbook : WB.Close True.
(if you don't want to save the changes made to the workbook use WB.Close False)
Note: you are not setting the Worksheet object on the workbook you open, so by default it will assume the ActiveSheet, which is the last ActiveSheet the last time you saved this workbook.
Try the code below:
Sub LoopThroughFiles()
Dim WB As Workbook
FolderName = "C:\Folder1\"
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
fname = Dir(FolderName & "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'loop through the files
Do While Len(fname)
Set WB = Workbooks.Open(FolderName & fname) '<-- set the workbook object
With WB
Dim tbl As ListObject
Dim rng As Range
Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium2"
Columns("A:L").Select
Columns("A:L").EntireColumn.AutoFit
End With
WB.Close True ' <-- close workbook and save changes
' go to the next file in the folder
fname = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have a requirement to open an existing file from a different location and save each worksheet into different csv files in the name of the worksheet name (tab name).
Sub SplitFile()
Dim vPath As String
vPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=vPath & "\" & xWs.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This works for the currently active workbook but I would like to process another workbook in a particular path.
I tried to assign a variable which holds the file path but it is throwing an error.
You need to create a workbook variable and assign a workbook object to it:
Sub SplitFile()
Dim vPath As String
Dim wb As Workbook
Dim wbPath As Variant
wbPath = Application.GetOpenFileName("Excel Files (*.xls*), *.xls*")
If wbPath = False Then Exit Sub
Set wb = Workbooks.Open(wbPath)
vPath = wb.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In wb.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=vPath & "\" & xWs.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
As you can see, once you've assigned your workbook you just refer to that in your code wherever needed.