I inherited VBA code that has not worked since my work updated our version of Excel.
The original code looped through all Excel files in a specific folder.
If data in specific cells was blank or a 0, would rename the whole workbook so I would know what files to delete after the fact.
This is the original code. I don't need it to do all of this anymore.
This is part one:
Sub AllFilesWeekly()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & filename)
'Call a subroutine here to operate on the just-opened workbook
Call getmetrics
On Error Resume Next
If Not ActiveWorkbook.Name Like "Audit Hub Report Distribution*" Then
ActiveWorkbook.Close
End If
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
The second part:
Sub getmetrics()
Dim cell As Range
Dim procstring As String, wbname As String
'Dim OQAYTD As String
Dim OQAMTD As String
Dim ORLYTD As String
Dim ORLMTD As String
Dim DR As String
Dim Audits As Long
Dim permonth As String, peryear As String, permonthrl As String, peryearrl As String
Dim RS As Worksheet, AD As Worksheet, QD As Worksheet, ws As Worksheet, YN As Boolean
For Each ws In Worksheets
If ws.Name = "Audit Detail" Then
YN = True
End If
Next ws
If YN = True Then
ActiveWorkbook.Sheets(2).Name = ("Rep Summary")
Set RS = ActiveWorkbook.Sheets("Rep Summary")
Set AD = ActiveWorkbook.Sheets("Audit Detail")
Set QD = ActiveWorkbook.Sheets("Question Detail")
With Sheets("Process Summary")
For Each cell In Range(Range("A3"), Range("A9999").End(xlUp))
If cell.Value = "Record Level YTD" Then
ORLYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "YTD Quality Average" Then
OQAYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Record Level Quality Average" Then
ORLMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Quality Average" Then
OQAMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Audits" Then
Audits = Range(cell.Address).Offset(0, 1).Value
End If
End If
End If
End If
End If
Next cell
End With
wbname = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
peryear = VBA.Format(OQAYTD, "Percent")
permonth = VBA.Format(OQAMTD, "Percent")
peryearrl = VBA.Format(ORLYTD, "Percent")
permonthrl = VBA.Format(ORLMTD, "Percent")
DR = Right(Sheets("Process Summary").Range("A2").Value, Len(Sheets("Process
Summary").Range("A2").Value) - 12)
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).AutoFilter
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).AutoFilter
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).AutoFilter
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
Application.DisplayAlerts = False
procstring = wbname & "|" & permonth & "|" & Audits & "|" & peryear & "|" & permonthrl & "|" &
peryearrl & "|" & DR ' & "|" & Users
Debug.Print procstring
Else
Application.DisplayAlerts = False
Dim AWN As String
AWN = ActiveWorkbook.FullName
Debug.Print "Not Audited: " & ActiveWorkbook.Name
ActiveWorkbook.SaveAs "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\Delete -" & Second(Now)
Kill AWN
ActiveWorkbook.Close savechanges:=True
Application.DisplayAlerts = True
End If
End Sub
All I need to do is look at cell D3 on the "Process Summary" tab.
If the value in that space is "0.00%", rename the workbook to delete and loop on until all workbooks are looked at.
I do not need to screen print all the extra numbers any more.
Build a Collection of filenames that match the criteria and then use it to rename the files.
Option Explicit
Sub AllFilesWeekly()
Dim folderPath As String, filename As String
Dim wb As Workbook, ws As Worksheet
Dim col As Collection, n As Long
Set col = New Collection
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
' scan folder
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Set wb = Workbooks.Open(folderPath & filename, True, True) ' update links, readonly
For Each ws In wb.Sheets
If ws.Name = "Process Summary" Then
If Format(ws.Range("D3"), "0.00%") = "0.00%" Then
col.Add wb.Name
End If
End If
Next
wb.Close
n = n + 1
filename = Dir
Loop
' result
MsgBox "Files scanned = " & n & vbCrLf & _
"To delete = " & col.Count, vbInformation, folderPath
' rename
If col.Count > 0 Then
If MsgBox("Continue to rename ?", vbYesNo) = vbYes Then
For n = 1 To col.Count
Name folderPath & col(n) As folderPath & "delete_" & col(n)
Next
MsgBox "Rename done"
End If
End If
End Sub
Related
I'm working on Excel for Mac, v16.53, with OS Catalina v10.15.7
I have an Excel workbook called SCRIPT with two sheets.
Sheet 1 has data entry areas and sheet 2 compiles those entries into a pseudo-table. The data in sheet 1 changes with every new person that is interviewed.
The data in sheet 2 is in columns A, B, H, I and J. It is non-contiguous and doesn't always have row 1 populated.
I can copy those five columns to a new csv file called Telesales-Leads-TODAY'S DATE.
The issue is when there already is a Telesales-Leads-TODAY'S DATE file.
The script is supposed to:
If Telesales-Leads-TODAY'S DATE file does not exist:
Start a new one.
Copy/paste the new SCRIPT data and save the Telesales-Leads-TODAY'S DATE file.
If a Telesales-Leads-TODAY'S DATE file does exist:
Copy the new data from the SCRIPT workbook to the first 100% empty column of the Telesales-Leads-TODAY'S DATE file.
Save the file with the same name (Telesales-Leads-TODAY'S DATE) in csv format.
It throws an error AFTER it copies the data from the SCRIPT workbook but BEFORE it has a chance to completely open the Telesales-Leads-TODAY'S DATE file.
I am using the MsgBox to debug.
Sub BackUpScriptData()
Dim strFileName As String
Dim strFileExists As String
Dim finalcolumn As Integer
Dim firstemptycolumn As Integer
Dim csvOpened As Workbook
Dim oneCell As Range
Dim myCSVFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim rngToSave As Range
Dim col As String
Dim ColumnNumber As Integer
Dim ColumnLetter As String
Dim colstart As String
Dim CellAddress As String
Dim TestChar As String
Dim NumberToLetter As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
On Error GoTo err
strFileName = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/User Content.localized/Startup.localized/Excel/" & "Telesales-Leads-" & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
strFileExists = Dir(strFileName)
If strFileExists = "" Then
MsgBox strFileName & " ~~~~~~~~doesn't exist"
Set myWB = ThisWorkbook
myCSVFileName = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/User Content.localized/Startup.localized/Excel/" & "Telesales-Leads-" & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
Set rngToSave = Range("A1:B69,H1:J69")
rngToSave.Copy
Set tempWB = Application.Workbooks.Add(1)
With tempWB
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
.SaveAs FileName:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
Else
Set myWB = ThisWorkbook
Set rngToSave = Range("A1:B69,H1:J69")
rngToSave.Copy
Set csvOpened = Workbooks.Open(FileName:=strFileName)
MsgBox "csvOpened is " & csvOpened
With csvOpened
Set oneCell = Range("A1")
Do While WorksheetFunction.CountA(oneCell.EntireColumn)
Set oneCell = oneCell.Offset(0, 1)
Loop
MsgBox "oneCell.Column is " & oneCell.Column
End With
CellAddress = Cells(1, ColNum).Address
For i = 2 To Len(CellAddress)
TestChar = Mid(CellAddress, i, 1)
If TestChar = "$" Then Exit For
NumberToLetter = NumberToLetter & Mid(CellAddress, i, 1)
Next i
MsgBox "colstart is " & colstart
With csvOpened
.Sheets(1).Range(colstart & "1").PasteSpecial xlPasteValues
.SaveAs FileName:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
End If
err: MsgBox "failed to copy."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The code is essentially the same for creating a new workbook or updating an existing, the only difference being the column where the data is to be pasted. As this is a csv file then UsedRange is a simple way to determine the last clear column.
Sub BackUpScriptData2()
Const FOLDER = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/" & _
"User Content.localized/Startup.localized/Excel/"
Const PREFIX = "Telesales-Leads-"
Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, rngToSave As Range
Dim colNum As Long, myCSVFileName As String
myCSVFileName = PREFIX & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
' check if file exists
If Len(Dir(FOLDER & myCSVFileName)) = 0 Then
' not exists
MsgBox "'" & myCSVFileName & "'" & vbCrLf & _
"does not exist, it will be created", vbInformation, FOLDER
Set wbCSV = Workbooks.Add()
colNum = 1
Else
' exists
Set wbCSV = Workbooks.Open(FOLDER & myCSVFileName)
With wbCSV.Sheets(1).UsedRange
colNum = .Column + .Columns.Count
End With
MsgBox "'" & myCSVFileName & "'" & vbCrLf & _
"exists, it will extended from column " & colNum, vbInformation, FOLDER
End If
' copy and save
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet2")
Set rngToSave = ws.Range("A1:B69,H1:J69")
rngToSave.Copy
With wbCSV
.Sheets(1).Cells(1, colNum).PasteSpecial xlPasteValues
.SaveAs Filename:=FOLDER & myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
MsgBox "File saved to " & myCSVFileName, vbInformation, FOLDER
End Sub
I have written this code and it has worked until now.
I have put two AutoFilter to pull certain rows. How do I amend the code to copy and paste visible rows?
I tried
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy'
which copies the cells but then I get an error. Object required
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
MyDir = "C:\Users\eldri\OneDrive\Desktop\New folder (2)\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
'opens excel
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False,
Password:=CalcPassword(MyFile))
Set TempSH = TempWB.Worksheets(1)
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Worksheets("Data").Range("A4").AutoFilter Field:=3, Criteria1:="AMS"
Worksheets("Data").Range("A4").AutoFilter Field:=4, Criteria1:="XNE"
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row)
NewMasterLine = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & (NewMasterLine + TempRng.Rows.Count))
MasterRange.Value = TempRng.Value
'Debug.Print "Imported File: " & MyFile & ", Imported Range: " & TempRng.Address & ", Destination Range: " & MasterRange.Address
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You cannot use Set and .Copy in one line.
First you need to set your range of visible cells:
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
Then you need to test if there were visible cells found and if so you can copy them:
If Not TempRng Is Nothing Then
TempRng.Copy
'all code that relies on the copied range `TempRng` needs to go here
Else
MsgBox "No visible cells found!"
End If
I rewrote the code with the advice from #PEH and it worked - Please find the new code below.
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
' Change address to suite
MyDir = "C:\Users\eldri\OneDrive\Desktop\W220Q1\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
' the operations required by the code and not on showing the changes happening on excel
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Here starts the loop related to the files in folder
Do While MyFile <> ""
'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Set TempSH = TempWB.Worksheets(1)
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows wiill start to be imported)
NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
'This will loop through all the rows of the range to be imported, checking the first column.
' If the value in the second column is work-xne-ams, will import the single row in the master worklbook
For Each TempRow In TempRng.Rows
If TempRow.Cells(1, 3).Value = "AMS" And TempRow.Cells(1, 4).Value = "XNE" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function CalcPassword(FileName As String) As String
CalcPassword = ""
On Error Resume Next
Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
End Function
I am a bit stuck with finishing the script below.
I got to this point and it does the basic thing I need it to do but it does need a bit of tweaking to get perfect.
It does the following: 1-pickup and prep master output file; 2- open each file in folder 'xls' and copy data from the designated sheet at the end of the master output file; 3-final edit of the master file; 4-save master file with name based on the input archives.
Where I need help is and was unable to fix up is: I want the script to cycle through subfolders in 'xls' folder and create a single master for each subfolder in 'xls' collecting data from files in that subfolder and name it after subfolder.
I understand I need another loop for subfolders but I am not really good with dirs in vba. Would this require a major overhaul?
Sub Joiner()
'Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim FileNAME As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim DayVar As String
Dim RangeVar As Variant
Dim LastRow As Long
Dim Targetsh As Worksheet
Dim RecordsCount As Long
' set master workbook
Workbooks.Open FileNAME:="C:\TA\output\Master Template.xlsx"
Set Masterwb = Workbooks("Master Template.xlsx")
Set Targetsh = Masterwb.Sheets("Data")
With ActiveWorkbook.Sheets("Data")
.Range("A1").FormulaR1C1 = "SysTime"
.Range("B1").FormulaR1C1 = "Seq#"
.Range("C1").FormulaR1C1 = "A1"
.Range("D1").FormulaR1C1 = "F2"
.Range("E1").FormulaR1C1 = "F3"
.Range("F1").FormulaR1C1 = "T4"
.Range("G1").FormulaR1C1 = "T5"
.Range("H1").FormulaR1C1 = "T6"
.Range("I1").FormulaR1C1 = "T7"
.Range("J1").FormulaR1C1 = "T8"
.Range("K1").FormulaR1C1 = "A9"
.Range("A1:K1").Font.Bold = True
.Range("A1:K1").Interior.ColorIndex = 19
.Range("L1").FormulaR1C1 = "Date"
.Range("M1").FormulaR1C1 = "Date/Seq#"
End With
folderPath = "C:\TA\xls\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False
FileNAME = Dir(folderPath & "*.xls*")
Do While FileNAME <> ""
Set wb = Workbooks.Open(folderPath & FileNAME)
'DayVar = Left(Right(wb.Name, 13), 8)
LastRow = wb.Sheets("Cleaned").Range("A1").End(xlDown).Row
RangeVar = wb.Sheets("Cleaned").Range("A2:K" & LastRow)
Targetsh.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(RangeVar, 1), UBound(RangeVar, 2)) = RangeVar
wb.Close False
Exit_Loop:
Set wb = Nothing
FileNAME = Dir
Loop
Application.ScreenUpdating = True
With Masterwb.Sheets("Data")
.Range(Range("A2"), Range("A2").End(xlDown)).NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
LastRow = ActiveWorkbook.Sheets("Data").Range("A1").End(xlDown).Row
With ActiveWorkbook.Sheets("Data")
.Range("L2").FormulaR1C1 = "=INT(C1)"
.Range("M2").FormulaR1C1 = "=C12&""-""&C2"
End With
Range("L2").AutoFill Destination:=Range("L2" & ":L" & LastRow)
With ActiveSheet
.Columns("L:L").Cells = .Columns("L:L").Cells.Value
End With
Range("M2").AutoFill Destination:=Range("M2" & ":M" & LastRow)
With ActiveSheet
.Columns("M:M").Cells = .Columns("M:M").Cells.Value
End With
With Masterwb.Sheets("Data")
.Range(Range("L2"), Range("L2").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
'Name the master output based on id
Dim FirstName As String
Dim InterName As String
Dim FinalName As String
Dim FilePath As String
FirstName = Dir("C:TA\Input\*.cab", vbNormal)
InterName = "Master Template " & Right(Left(FirstName, 12), 4)
'MsgBox FirstName
'MsgBox InterName
FilePath = "C:\TA\output"
ActiveWorkbook.SaveAs FileNAME:=FilePath & "\" & InterName & ".xlsx", _
FileFormat:=51, CreateBackup:=False
'
End Sub
Thank you for any advice.
With this code you can list excel files in a folder and subfolders
Sub ListSubfoldersFile() ' only one level subfolders
arow = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "F:\Download\" ' path to change
Set mainFolder = objFSO.GetFolder(mFolder)
StrFile = Dir(mFolder & "*.xls*")
Do While Len(StrFile) > 0
Cells(arow, 1).Value = mFolder & StrFile
arow = arow + 1
StrFile = Dir
Loop
For Each mySubFolder In mainFolder.subfolders
StrFile = Dir(mySubFolder & "\*.xls*")
Do While Len(StrFile) > 0
Cells(arow, 1).Value = mySubFolder & "\" & StrFile
arow = arow + 1
StrFile = Dir
Loop
Next
End Sub
Thank you Patel!
I used your solution to complement my current vba snippet.
It may be a bit clunky but it does what I need it to do.
Thank you.
Posting a solution below for the benefit of the community.
Sub MassJoiner()
'this is a version of joiner with subfolders
'Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim FileNAME As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim DayVar As String
Dim RangeVar As Variant
Dim LastRow As Long
Dim Targetsh As Worksheet
Dim RecordsCount As Long
Dim StrFile As String
Dim mFolder As String
Dim BatchCount As Long
Dim ID As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "D:\TA\TEST\" ' path to change
Set mainFolder = objFSO.GetFolder(mFolder)
StrFile = Dir(mFolder & "*.xls*")
BatchCount = 0
Workbooks.Open FileNAME:="C:\TA\output\Master Template.xlsx"
For Each mySubFolder In mainFolder.subfolders
StrFile = Dir(mySubFolder & "\*.xls*")
Do While Len(StrFile) > 0
Set Masterwb = Workbooks("Master Template.xlsx")
Set Targetsh = Masterwb.Sheets("Data")
With ActiveWorkbook.Sheets("Data")
.Range("A1").FormulaR1C1 = "SysTime"
.Range("B1").FormulaR1C1 = "Seq#"
.Range("C1").FormulaR1C1 = "A1"
.Range("D1").FormulaR1C1 = "F2"
.Range("E1").FormulaR1C1 = "F3"
.Range("F1").FormulaR1C1 = "T4"
.Range("G1").FormulaR1C1 = "T5"
.Range("H1").FormulaR1C1 = "T6"
.Range("I1").FormulaR1C1 = "T7"
.Range("J1").FormulaR1C1 = "T8"
.Range("K1").FormulaR1C1 = "A9"
.Range("A1:K1").Font.Bold = True
.Range("A1:K1").Interior.ColorIndex = 19
.Range("L1").FormulaR1C1 = "Date"
.Range("M1").FormulaR1C1 = "Date/Seq# pair"
End With
'FileNAME = Dir(folderPath & "*.xls*")
'Do While FileNAME <> ""
Set wb = Workbooks.Open(mySubFolder & "\" & StrFile)
'DayVar = Left(Right(wb.Name, 13), 8)
LastRow = wb.Sheets("Cleaned").Range("A1").End(xlDown).Row
RangeVar = wb.Sheets("Cleaned").Range("A2:K" & LastRow)
Targetsh.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(RangeVar, 1), UBound(RangeVar, 2)) = RangeVar
wb.Close False
'Exit_Loop:
' Set wb = Nothing
' FileNAME = Dir
'Loop
StrFile = Dir
Loop
With Masterwb.Sheets("Data")
.Range(Range("A2"), Range("A2").End(xlDown)).NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
LastRow = ActiveWorkbook.Sheets("Data").Range("A1").End(xlDown).Row
With ActiveWorkbook.Sheets("Data")
.Range("M2").FormulaR1C1 = "Date/Seq# pair"
.Range("m2").FormulaR1C1 = "=C12&""-""&C2"
End With
Range("L2").AutoFill Destination:=Range("L2" & ":L" & LastRow)
With ActiveSheet
.Columns("L:L").Cells = .Columns("L:L").Cells.Value
End With
Range("M2").AutoFill Destination:=Range("M2" & ":M" & LastRow)
With ActiveSheet
.Columns("M:M").Cells = .Columns("M:M").Cells.Value
End With
With Masterwb.Sheets("Data")
.Range(Range("l2"), Range("l2").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
'Name the master output based on job id
Dim FirstName As String
Dim InterName As String
Dim FinalName As String
Dim FilePath As String
FirstName = mySubFolder
InterName = "Master Template " & Right(FirstName, 4)
ID = Right(FirstName, 4)
'MsgBox FirstName
'MsgBox InterName
FilePath = "C:\TA\output"
ActiveWorkbook.SaveAs FileNAME:=FilePath & "\" & InterName & ".xlsx", _
FileFormat:=51, CreateBackup:=False
ActiveWorkbook.Close False
BatchCount = BatchCount + 1
Application.Speech.Speak "Batch job" & BatchCount & "finalized. ID" & ID
Workbooks.Open FileNAME:="C:\output\Master Template.xlsx"
Next
Application.ScreenUpdating = True
End Sub
My code copy the open workbook and then renames the copied one with the month of analysis, but I need to save all the analysis of the month doing a sequence at the end of the file name. I tried some simple loops and it doesn't work.
Sub NewReport()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim dateStr As String
Dim myDate As Date
Dim i As Integer
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb1 = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
Set Wb2 = Application.Workbooks.Add(1)
Wb1.Sheets(Array(Wb1.Sheets(1).Name)).Copy Before:=Wb2.Sheets(1)
Wb2.Sheets(Wb2.Sheets.Count).Delete
On Error GoTo Fim
'Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr, FileFormat:=51
'Wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
Fim:
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_", FileFormat:=51
End Sub
UPDATE
I tried put an "i + 1" and the macro runs until version 2! But at the 3rd I have the same error because the "i" is reseted. I can do the bit at the end for like 50 times assuming that the person don't run the macro 50 times haha. Any suggestions?
Sub NewReport()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim dateStr As String
Dim myDate As Date
i = 1
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb1 = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
Set Wb2 = Application.Workbooks.Add(1)
Wb1.Sheets(Array(Wb1.Sheets(1).Name)).Copy Before:=Wb2.Sheets(1)
Wb2.Sheets(Wb2.Sheets.Count).Delete
On Error GoTo Fim
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i, FileFormat:=51
'Wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
Fim:
i = i + 1
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i, FileFormat:=51
End Sub
So, the question is how to get from something like:
\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_21
an incremented value at the end like this one:
\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_22
This could be carried out through the following steps:
Take the string and split it by _.
Increment the last part of the string with 1.
Public Sub TestMe()
Dim fileName As String
Dim dateStr As String: dateStr = "probablySomeString"
Dim i As Long: i = 21
fileName = "\\BRGABS001\g_supc\P.C.P\07- Comum\" & _
"Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i
Debug.Print fileName
Debug.Print Increment(fileName)
End Sub
Public Function Increment(fileName As String) As String
Dim myResult As String
Dim newValue As Long
Dim myArr As Variant
newValue = Split(fileName, "_")(UBound(Split(fileName, "_"))) + 1
myArr = Split(fileName, "_")
myArr(UBound(Split(fileName, "_"))) = newValue
Increment = Join(myArr, "_")
End Function
And if the initial file looks like this:
~omum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_21.xlsx then
the following sample works:
Public Sub TestMe()
Dim fileName As String
Dim dateStr As String: dateStr = "probablySomeString"
Dim i As Long: i = 21
fileName = "\\BRGABS001\g_supc\P.C.P\07- Comum\" & _
"Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i & ".xlsx"
Debug.Print fileName
Debug.Print Increment(fileName)
End Sub
Public Function Increment(fileName As String) As String
Dim myResult As String
Dim newValue As Long
Dim myArr As Variant
newValue = Split(Split(fileName, "_")(UBound(Split(fileName, "_"))), ".")(0) + 1
myArr = Split(fileName, "_")
myArr(UBound(Split(fileName, "_"))) = newValue
Increment = Join(myArr, "_")
Increment = Increment & ".xslx"
End Function
After a deep research on google, I found a code and adapt to my situation. It doesn't let to choose the way to save, it's just in the same Folder, but that's ok to me. Credits on the code (I have just put the date at the name):
Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
'RESOURCE: http://www.rondebruin.nl/win/s9/win003.htm
Dim TestStr As String
'Test File Path (ie "C:\Users\Chris\Desktop\Test\book1.xlsm")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
Sub SaveNewVersion_Excel()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim dateStr As String
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
TestStr = ""
Saved = False
x = 2
'Version Indicator (change to liking)
VersionExt = "_" & dateStr & "_Rev"
'Pull info about file
On Error GoTo NotSavedYet
myPath = ActiveWorkbook.FullName
myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
On Error GoTo 0
'Determine Base File Name
If InStr(1, myFileName, VersionExt) > 1 Then
myArray = Split(myFileName, VersionExt)
SaveName = myArray(0)
Else
SaveName = myFileName
End If
'Test to see if file name already exists
If FileExist(FolderPath & SaveName & SaveExt) = False Then
ActiveWorkbook.SaveAs FolderPath & SaveName & SaveExt
Exit Sub
End If
'Need a new version made
Do While Saved = False
If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
ActiveWorkbook.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt
Saved = True
Else
x = x + 1
End If
Loop
'New version saved
MsgBox "New file version saved (version " & x & ")"
Exit Sub
'Error Handler
NotSavedYet:
MsgBox "This file has not been initially saved. " & _
"Cannot save a new version!", vbCritical, "Not Saved To Computer"
End Sub
I would like to say i'm an intermediate user of Excel VBA but i'm struggling with this one.
I have written a script to read a text file and strip out all the information I need and then add it to Worksheet that is named by the text file name and then todays date.
Set WS1 = ActiveWorkbook.Sheets("Home")
myFile = Application.GetOpenFilename()
myFileName = FileNameOf(myFile)
WS1.Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
strNewSheetName = myFileName & " - " & Format(Now, "DD-MM-YY")
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
If blnSheetCheck = True Then
blnDeleteSheet = MsgBox("NOTICE:" & vbCrLf & vbCrLf & "This text file has already been added today!!" & vbCrLf & vbCrLf & "would you like to delete the existing one?", vbYesNo + vbCritical)
If blnDeleteSheet = vbYes Then
ActiveWorkbook.Sheets(strNewSheetName).Delete
WS2.Name = strNewSheetName
Else
' Roll the number here
End If
Else
WS2.Name = strNewSheetName
End If
I use this function to check if it exists
Function CheckIfSheetExists(SheetName) As Boolean
CheckIfSheetExists = False
Err.Clear
On Error Resume Next
Set WS99 = Sheets(SheetName)
If Err = 0 Then
CheckIfSheetExists = True
Else
CheckIfSheetExists = False
End If
End Function
When I first wrote the code I was going to add a time to the sheet name but it will sometimes push the name over the 31 character limit.
So I would like some guidance on how I can add a numeric to the end of the sheet name and then repeat the process to see if that sheet name exists and then move it up a number and then check again.
Thank you in advance
Andy
This will name the sheets as, for example:
Test 03-05-18 and then Test 03-05-18_01 up to Test 03-05-18_99.
Update this line to allow more copies:
TempShtName = SheetName & "_" & Format(lCounter, "00")
There's one procedure and two functions in the code:
The first is a copy of your code (with variables declare).
The second figures out the name of the sheet.
The third checks if the sheet exists.
Public Sub Test()
Dim WrkBk As Workbook
Dim WS1 As Worksheet, WS2 As Worksheet
Dim myFile As String
Dim myFileName As String
myFile = Application.GetOpenFilename()
'File name including extension:
'myFileName = Mid(myFile, InStrRev(myFile, "\") + 1)
'File name excluding extension:
myFileName = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1)
With ThisWorkbook
Set WS1 = .Sheets("Home")
WS1.Copy After:=.Worksheets(.Worksheets.Count)
Set WS2 = .Worksheets(.Worksheets.Count)
WS2.Name = GetSheetName(myFileName & " - " & Format(Now, "dd-mm-yy"))
End With
End Sub
'Return a numbered sheet name (or the original if it's the first).
Public Function GetSheetName(SheetName As String, Optional WrkBk As Workbook) As String
Dim wrkSht As Worksheet
Dim TempShtName As String
Dim lCounter As Long
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
TempShtName = SheetName
Do While WorkSheetExists(TempShtName)
lCounter = lCounter + 1
TempShtName = SheetName & "_" & Format(lCounter, "00")
Loop
GetSheetName = TempShtName
End Function
'Check if the sheet exists.
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Edit:
To remove illegal characters and keep the sheet name to 31 characters you could add this code in the GetSheetName function just before the TempShtName = SheetName line:
Dim x As Long
Dim sChr As String
Const ILLEGAL_CHR As String = "\/*?:[]"
For x = 1 To Len(SheetName)
sChr = Mid(SheetName, x, 1)
If InStr(ILLEGAL_CHR, sChr) > 0 Then
SheetName = Replace(SheetName, sChr, "_")
End If
Next x
If Len(SheetName) > 28 Then
SheetName = Left(SheetName, 28)
End If
Set WS1 = ActiveWorkbook.Sheets("Home")
myFile = Application.GetOpenFilename()
myFileName = FileNameOf(myFile)
WS1.Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
strNewSheetName = myFileName & " - " & Format(Now, "DD-MM-YY")
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
If blnSheetCheck = True Then
blnDeleteSheet = MsgBox("NOTICE:" & vbCrLf & vbCrLf & "This text file has already been added today!!" & vbCrLf & vbCrLf & "would you like to delete the existing one?", vbYesNo + vbCritical)
If blnDeleteSheet = vbYes Then
ActiveWorkbook.Sheets(strNewSheetName).Delete
WS2.Name = strNewSheetName
Else
'======Here's the new bit=================
Dim x as integer
x = 1
Do
strnewsheetname = left(strnewsheetname,30) & x
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
x = x +1
Loop while blnSheetCheck
WS2.Name = strNewSheetName
'=============End of New Bit=============
End If
Else
WS2.Name = strNewSheetName
End If
Technically this will keep looping above 9, but from you've said I don't think this will be a problem