I have a worksheet (QT) that gets filled in by the user and when the user closes the workbook a UserForm appears before closing. The user then selects a few things and the code runs. The code inserts data into another workbook (Log). My problem is the other workbook (Log) asks the user if they would like to save. I need for this step to be skipped. I have tried Application.DisplayAlerts = False but it does not prevent it from popping up.
Private Sub OKBTN_Click()
Dim TOTALFOB As String
Dim TOTALWC As String
Dim MFG As String
Dim JOB As String
Dim XL As Excel.Application
Dim wbk As Excel.Workbook
Dim INWBK As Excel.Workbook
Dim TOTMFG As Variant
Dim TOTWC As Variant
Dim visitdate As Date
Dim visitdate_text As String
TOTALFOB = RefEdit1
TOTALWC = RefEdit2
Set XL = CreateObject("Excel.Application")
Set INWBK = ActiveWorkbook
Set wbk = XL.Workbooks.Open("C:\QUOTE REQUEST LOG 2015.xlsm")
If YESBTN.Value = True Then TOTMFG = INWBK.Sheets("QTR").Range(TOTALFOB).Value
If YESBTN.Value = True Then TOTWC = INWBK.Sheets("QTR").Range(TOTALWC).Value
If NOBTN.Value = True Then TOTMFG = "N/A"
If NOBTN.Value = True Then TOTWC = "N/A"
MFG = INWBK.Sheets("QTR").Range("B7").Value
JOB = INWBK.Sheets("QTR").Range("H13").Value
visitdate = INWBK.Sheets("QTR").Range("H9").Value
visitdate_text = Format$(visitdate, "mm\-dd\-yyyy")
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = INWBK.Sheets("QTR").Range("B7").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 1) = INWBK.Sheets("QTR").Range("H11").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 3) = INWBK.Sheets("QTR").Range("H13").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 4) = TOTMFG
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 5) = TOTWC
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 6) = "OPEN"
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 7) = INWBK.Sheets("QTR").Range("H9").Value
Application.DisplayAlerts = False
INWBK.SaveAs Filename:="C:\. QUOTE REQUESTS" & _
"\DCS QTR " & MFG & " " & " " & JOB & " " & visitdate_text & ".xlsx", _
FileFormat:=51, CreateBackup:=False, local:=True
Set XL = Nothing
Unload Me
wbk.Close
End Sub
Code from output file (Workbook Log):
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ThisWorkbook.Save
End Sub
try ThisWorkbook.Saved = True
Even if the workbook is not saved, excel will act as if it was saved
Related
We have added 5 new columns to three sheets in a workbook. The first sheet is like a staging table that then populates the other two. The problem is the new columns are not being populated with the data in the two final sheets. The data is visible in the intial sheet. I think it may be an issue with the Advanced Filter but im not sure. Any help would be appreciated.
Public Sub RunExtract()
Dim strExtractYear As String
Dim strExtractMonth As String
Dim strOutputFolder As String
Application.ScreenUpdating = False
'grab the control variable values
strExtractYear = Range("Extract_Year").Value
strExtractMonth = Range("Extract_Month").Value
strOutputFolder = Range("Output_Folder").Value
'pull the data
Application.StatusBar = "Pulling data..."
Call PullData(strExtractYear, strExtractMonth)
'filter and output the results
Application.StatusBar = "Extracting 310 summary data..."
Range("SummaryFilter.Criteria").Cells(2, 2).Formula = "=""=310"""
Call FilterData(Range("SalesExtract.Table"), Range("SummaryFilter.Criteria"), Range("SummaryFilter.Header"), "SummaryFilter.Table")
Call OutputResults("SUMMARY", "310", strOutputFolder)
Application.StatusBar = "Extracting 430 summary data..."
Range("SummaryFilter.Criteria").Cells(2, 2).Formula = "=""=430"""
Call FilterData(Range("SalesExtract.Table"), Range("SummaryFilter.Criteria"), Range("SummaryFilter.Header"), "SummaryFilter.Table")
Call OutputResults("SUMMARY", "430", strOutputFolder)
Application.StatusBar = "Extracting 310 detail data..."
Range("DetailFilter.Criteria").Cells(2, 2).Formula = "=""=310"""
Call FilterData(Range("SalesExtract.Table"), Range("DetailFilter.Criteria"), Range("DetailFilter.Header"), "DetailFilter.Table")
Call OutputResults("DETAIL", "310", strOutputFolder)
Application.StatusBar = "Extracting 430 detail data..."
Range("DetailFilter.Criteria").Cells(2, 2).Formula = "=""=430"""
Call FilterData(Range("SalesExtract.Table"), Range("DetailFilter.Criteria"), Range("DetailFilter.Header"), "DetailFilter.Table")
Call OutputResults("DETAIL", "430", strOutputFolder)
Call CleanUpThisWorkbook
Application.StatusBar = "Done"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Public Sub PullData(ExtractYear As String, ExtractMonth As String)
Dim conn As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim strStartDate As String
Dim strStartDateTime As String
Dim strEndDateTime As String
Dim strYear As String
Dim strMonth As String
Dim strLastDay As String
'clear the existing range
Range("SalesExtract.Table").CurrentRegion.Offset(1).EntireRow.Delete
'figure out the start and end datetimes
strYear = ExtractYear
strMonth = Right("0" & ExtractMonth, 2)
strStartDate = "{year}-{month}-{day}"
strStartDate = Replace(strStartDate, "{year}", strYear)
strStartDate = Replace(strStartDate, "{month}", strMonth)
strStartDate = Replace(strStartDate, "{day}", "01")
strStartDateTime = strStartDate & " 00:00:00"
strLastDay = CStr(Day(DateSerial(Year(strStartDate), Month(strStartDate) + 1, 0)))
strEndDateTime = "{year}-{month}-{day} 23:59:59"
strEndDateTime = Replace(strEndDateTime, "{year}", strYear)
strEndDateTime = Replace(strEndDateTime, "{month}", strMonth)
strEndDateTime = Replace(strEndDateTime, "{day}", strLastDay)
Private Sub OutputResults(Level As String, Company As String, Directory As String)
Dim wb As Workbook
Set wb = Workbooks.Add
Dim strSheet As String
If Level = "SUMMARY" Then
strSheet = "SummaryFilter"
ElseIf Level = "DETAIL" Then
strSheet = "DetailFilter"
Else
'raise error
End If
Call ThisWorkbook.Worksheets(strSheet).Range(strSheet & ".Table").Copy
Call wb.Worksheets(1).Range("A1").PasteSpecial(xlPasteValues)
Call ThisWorkbook.Worksheets(strSheet).Range(strSheet & ".ReplacementHeader").Copy
Call wb.Worksheets(1).Range("A1").PasteSpecial(xlPasteValues)
wb.Worksheets(1).Name = Level & " " & Company
Application.DisplayAlerts = False
Call wb.SaveAs(Directory & "\Sales Extract - " & Level & " " & Company & ".xlsx")
Application.DisplayAlerts = True
Call wb.Close
Set wb = Nothing
End Sub
Private Sub FilterData(FilterRng As Range, CriteriaRng As Range, CopyToRng As Range, NameMe As String, Optional FilterUnique As Boolean)
With CopyToRng
If WorksheetFunction.CountA(.Offset(1, 0).Resize(1, .Columns.Count)) <> 0 Then
CopyToRng.CurrentRegion.Offset(1, 0).ClearContents
End If
End With
FilterRng.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=CriteriaRng, _
CopyToRange:=CopyToRng, _
Unique:=FilterUnique
CopyToRng.CurrentRegion.Name = NameMe
End Sub
Private Sub CleanUpThisWorkbook()
Range("SalesExtract.Table").Offset(1).EntireRow.Delete
Range("SummaryFilter.Table").Offset(1).EntireRow.Delete
Range("DetailFilter.Table").Offset(1).EntireRow.Delete
End Sub
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
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 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
I am getting a subscript out of range error when another user runs my add in but have no problems when running the same code myself. This happens when setting a workbook value. The filename is being generated by getting the current date and stored as gendate. From this, the filename is created and saved based on the filepath that the user has made. In this example, the value of gv.Range("b2").text is C:\Users\username\Desktop\ReportGeneration. fp is therefore C:\Users\dmulhausen\Desktop\ReportGeneration\TSReports9_6_201615h5m32s.xlsx
This is not generating an error for me, but it is generating an error for another user of the script.
Dim ai As Workbook 'add in data ---Initialized in Report Setup
Dim dwb As Workbook 'destination workbook ---Initialized in Report Setup
Dim ss As Worksheet 'source sheet
Dim ds As Worksheet 'destination sheet or writing sheet
Dim rv As Worksheet 'reporting variables sheet ---Initialized in Report Setup
Dim pv As Worksheet 'ts variables sheet ---Initialized in Report Setup
Dim gv As Worksheet 'global ai variables ---Initialized in Report Setup
Dim tempstr As String
Dim fp As String 'file path ---Initialized in Report Setup
Dim gendate As Date
Dim reportscreated As Integer
Dim initialized As Boolean
Dim sheetnames(1 To 12) As String
Sub reportsetup()
Set ai = Workbooks("TSReports add in.xlam")
Set rv = ai.Worksheets("ReportVars")
Set pv = ai.Worksheets("TS1_2Vars")
Set gv = ai.Worksheets("globalVars")
If (IsEmpty(gv.Range("b2").Value)) Then
MsgBox ("Please select a designated folder for reports")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
gv.Range("b2").Value = .SelectedItems(1)
End If
ai.Save
End With
End If
initialized = True
gendate = Now()
tempstr = "TSReports" & Month(gendate) & "_" & Day(gendate) & "_" & Year(gendate) & Hour(gendate) & "h" & Minute(gendate) & "m" & Second(gendate) & "s"
fp = gv.Range("b2").Text & "\" & tempstr & ".xlsx"
Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fp
Set dwb = Workbooks(tempstr) '*******Error occurs here*******
See: Windows().Activate works on every computer except one
This should fix the issue.
tempstr = "TSReports" & Month(gendate) & "_" & Day(gendate) & "_" & _
Year(gendate) & Hour(gendate) & "h" & Minute(gendate) & "m" & _
Second(gendate) & "s" & ".xlsx"
fp = gv.Range("b2").Text & "\" & tempstr
Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fp
Set dwb = Workbooks(tempstr)
However this would be more robust:
Set dwb = Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
dwb.SaveAs Filename:=fp