Hi all,
I'm building a macro that creates reports (100+) containing 2 tabs. It does this by extracting all of the data for multiple companies (ODBC DSN) and then copy/pasting the applicable info, for each individual company, to a template file. The macro saves the file and when it's done with the 1st tab, it does it all over again for the 2nd tab.
The macro appears to be working fine for the 1st part but it's hanging up at some point during the 2nd half. It's odd because it works for about 15 companies, and then gets hung up. The piece of code that is referenced when I debug is:
'Have macro wait until the file opens in full edit mode
Do Until Wb.ReadOnly = False
Application.Wait (Now + TimeValue("00:00:01"))
If Wb Is Nothing Then
Exit Do
End If
Set Wb = Workbooks.Open(tfile & Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx")
Loop
I added the "Do Until...." piece because previously, the macro would run for a bit and then just fail and close. I thought this was because it was taking too long for the template file to open so I initially had it wait a couple of seconds. This allowed the macro to process a little longer before ultimately stopping again. With the above code, I've been able to get it to run the longest. However, now the code is stuck at the part where it can't find an existing file but won't open the template file.
Can anyone tell me where I'm going wrong? I've included the whole code for the 2nd half of my macro below.
Thank you in advance!
'Declaring variables
Dim LR As Long
Dim iLeft As Long
Dim sDestPath As String
Dim sSaveFilename As String
Dim mBook As String, PID As String
Dim bfile As String, bBook As String
Dim tfile As String, tBook As String
Dim Wb As Workbook
Dim Tb As Workbook
Dim Wkb As Workbook
Dim wsSR As Worksheet
Dim wsNew As Worksheet
'Turn off excel prompts
Application.ScreenUpdating = False
Application.EnableEvents = False
'Turn off popup alerts/messages
'Application.DisplayAlerts = False
'Name SRSRVPRCLL macro template
mBook = ActiveWorkbook.Name
'Activate table tab '%%%%%%%%%'
Workbooks(mBook).Worksheets("table").Activate
'Name table tab
Set wsSR = ActiveSheet
'Delete Price and Service Level Change data table
Cells.ClearContents
'Get OPENCLSALL Data from ODBC DSN/ Allied/ NAREPTSQL
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"ODBC;DSN=Allied.NAREPTSQL;", Destination:=Range("$A$1")).QueryTable
.CommandText = Array( _
"SELECT * FROM ""ALLIED"".""NAREPTSQL"".""OPENCLSALL""")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceConnectionFile = _
"\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Monthly Standard Reports\Price and Service Level Changes\zzDO NOT TOUCH\ALLIED OPENCLSALL.odc"
.ListObject.DisplayName = "Table_ALLIED_OPENCLSALL_1"
.Refresh BackgroundQuery:=False
End With
'Find last used row on the table tab
LR = Workbooks(mBook).Sheets("table").Cells(1, 2).End(xlDown).Row
'Copy data and paste special values onto Changes tab
Workbooks(mBook).Sheets("table").Range("A2:AB" & LR).Copy
Workbooks(mBook).Sheets("Open Closed").Range("A2").PasteSpecial xlPasteValues
'Copy format down to the last row
ActiveWorkbook.Worksheets("Open Closed").Range("A2:AB2").Copy
ActiveWorkbook.Worksheets("Open Closed").Range("A3:AB" & LR).PasteSpecial xlPasteFormats
'Activate Open Closed tab
ActiveWorkbook.Worksheets("Open Closed").Activate
'Name Open Closed tab
Set wsSR = ActiveSheet
'Find last used row on the Open Closed tab
LR = Workbooks(mBook).Sheets("Open Closed").Cells(1, 2).End(xlDown).Row
'Add autofilter
Workbooks(mBook).Worksheets("Open Closed").Range("A1").AutoFilter
'Sort by Parent ID (column B)
ActiveWorkbook.Worksheets("Open Closed").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Open Closed").Sort.SortFields.Add Key:=Range( _
"B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Open Closed").Sort
.SetRange Range("A1:AB" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Create list of all distinct Parent IDs in column AH - to be used in autofilter
ActiveWorkbook.Worksheets("Open Closed").Range("B2", Range("B2").End(xlDown)).Copy Range("AH2")
ActiveWorkbook.Worksheets("Open Closed").Range("AH1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
iLeft = Range("AH1").CurrentRegion.Rows.Count - 1
Do While iLeft > 0
'Get current Parent ID to open appropriate file
PID = wsSR.Range("AH1").Offset(iLeft).Value
'iLeft = iLeft - 1
'Set SRSRVPRC file to add OpenClosed info to
tfile = "\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Monthly Standard Reports\Price and Service Level Changes\"
On Error Resume Next
Set Wb = Workbooks.Open(tfile & Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx")
'Have macro wait until the file opens in full edit mode
Do Until Wb.ReadOnly = False
Application.Wait (Now + TimeValue("00:00:01"))
If Wb Is Nothing Then
Exit Do
End If
Set Wb = Workbooks.Open(tfile & Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx")
Loop
If Wb Is Nothing Then
'Set SRSRVPRC template
tfile = "\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Customer Report Templates\_Templates\"
Workbooks.Open (tfile), False, ReadOnly:=False
Set Tb = Workbooks.Open(tfile & "NB_Price and Service Level Change with open closed containers tab rev.xlsx")
'Have macro wait until the file opens in full edit mode
Do Until Tb.ReadOnly = False
Application.Wait (Now + TimeValue("00:00:01"))
Set Tb = Workbooks.Open(tfile & "NB_Price and Service Level Change with open closed containers tab rev.xlsx")
Loop
tBook = ActiveWorkbook.Name
'Enter message on Service or Price Level Changes tab
Workbooks(tBook).Worksheets("Service or Price Level Changes").Range("A4").Value = "Nothing to report."
'Activate Containers Opened or Closed tab
Workbooks(tBook).Worksheets("Containers Opened or Closed").Activate
Set wsNew = ActiveSheet
'Copy each Parent ID to a separate SRSRVPRC file
With wsSR.Range("B2").CurrentRegion
.AutoFilter field:=2, _
Criteria1:=wsSR.Range("AH1").Offset(iLeft).Value
.Copy Workbooks(tBook).Worksheets("Containers Opened or Closed").Range("A3")
.AutoFilter
End With
'Apply correct formatting to Column Headers
With wsNew.Range("A3:AB3")
.Interior.ThemeColor = xlThemeColorDark2
.Font.Bold = True
.Font.ThemeColor = xlThemeColorDark1
.Font.Name = "Open Sans"
End With
'Resize all columns
Workbooks(tBook).Worksheets(wsNew).Cells.Select
Workbooks(tBook).Worksheets(wsNew).Cells.EntireColumn.AutoFit
'End with cursor on cell A4
Workbooks(tBook).Worksheets(wsNew).Range("A4").Select
Workbooks(tBook).Worksheets(wsNew).Range("A4").Activate
'Path of SRSRVPRC Folder
sDestPath = "\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Monthly Standard Reports\Price and Service Level Changes\"
'Naming convention for new SRSRVPRC
sSaveFilename = Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx"
'Save new SRSRVPRC with naming convention and to the path outlined above
ActiveWorkbook.SaveCopyAs sDestPath & sSaveFilename
'PID = Empty
tfile = Empty
wsNew = Empty
Wb = Empty
Tb = Empty
tBook = Empty
Workbooks(tBook).Close False
Else
'tfile = "\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Monthly Standard Reports\Price and Service Level Changes\" & Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx"
'Open appropriate SRSRVPRC File
'Workbooks.Open (tfile), False, ReadOnly:=False
tBook = ActiveWorkbook.Name
'Activate Open Closed tab
Workbooks(tBook).Worksheets("Containers Opened or Closed").Activate
Set wsNew = ActiveSheet
'Copy each Parent ID to a separate SRSRVPRC file
With wsSR.Range("B2").CurrentRegion
.AutoFilter field:=2, _
Criteria1:=wsSR.Range("AH1").Offset(iLeft).Value
.Copy Workbooks(tBook).Worksheets("Containers Opened or Closed").Range("A3")
.AutoFilter
End With
'Apply correct formatting to Column Headers
With wsNew.Range("A3:AB3")
.Interior.ThemeColor = xlThemeColorDark2
.Font.Bold = True
.Font.ThemeColor = xlThemeColorDark1
.Font.Name = "Open Sans"
End With
'Resize all columns
Workbooks(tBook).Worksheets(wsNew).Cells.Select
Workbooks(tBook).Worksheets(wsNew).Cells.EntireColumn.AutoFit
'End with cursor on cell A3
Workbooks(tBook).Worksheets(wsNew).Range("A4").Select
Workbooks(tBook).Worksheets(wsNew).Range("A4").Activate
'Activate Containers Opened or Closed tab
Worksheets("Service or Price Level Changes").Activate
'Save spreadsheet
ActiveWorkbook.Save
'PID = Empty
tfile = Empty
wsNew = Empty
Workbooks(tBook).Close False
End If
iLeft = iLeft - 1
Loop
I'm building a macro that creates reports (100+) containing 2 tabs. It does this by extracting all of the data for multiple companies (ODBC DSN) and then copy/pasting the applicable info, for each individual company, to a template file. The macro saves the file and when it's done with the 1st tab, it does it all over again for the 2nd tab.
The macro appears to be working fine for the 1st part but it's hanging up at some point during the 2nd half. It's odd because it works for about 15 companies, and then gets hung up. The piece of code that is referenced when I debug is:
'Have macro wait until the file opens in full edit mode
Do Until Wb.ReadOnly = False
Application.Wait (Now + TimeValue("00:00:01"))
If Wb Is Nothing Then
Exit Do
End If
Set Wb = Workbooks.Open(tfile & Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx")
Loop
I added the "Do Until...." piece because previously, the macro would run for a bit and then just fail and close. I thought this was because it was taking too long for the template file to open so I initially had it wait a couple of seconds. This allowed the macro to process a little longer before ultimately stopping again. With the above code, I've been able to get it to run the longest. However, now the code is stuck at the part where it can't find an existing file but won't open the template file.
Can anyone tell me where I'm going wrong? I've included the whole code for the 2nd half of my macro below.
Thank you in advance!
'Declaring variables
Dim LR As Long
Dim iLeft As Long
Dim sDestPath As String
Dim sSaveFilename As String
Dim mBook As String, PID As String
Dim bfile As String, bBook As String
Dim tfile As String, tBook As String
Dim Wb As Workbook
Dim Tb As Workbook
Dim Wkb As Workbook
Dim wsSR As Worksheet
Dim wsNew As Worksheet
'Turn off excel prompts
Application.ScreenUpdating = False
Application.EnableEvents = False
'Turn off popup alerts/messages
'Application.DisplayAlerts = False
'Name SRSRVPRCLL macro template
mBook = ActiveWorkbook.Name
'Activate table tab '%%%%%%%%%'
Workbooks(mBook).Worksheets("table").Activate
'Name table tab
Set wsSR = ActiveSheet
'Delete Price and Service Level Change data table
Cells.ClearContents
'Get OPENCLSALL Data from ODBC DSN/ Allied/ NAREPTSQL
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"ODBC;DSN=Allied.NAREPTSQL;", Destination:=Range("$A$1")).QueryTable
.CommandText = Array( _
"SELECT * FROM ""ALLIED"".""NAREPTSQL"".""OPENCLSALL""")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceConnectionFile = _
"\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Monthly Standard Reports\Price and Service Level Changes\zzDO NOT TOUCH\ALLIED OPENCLSALL.odc"
.ListObject.DisplayName = "Table_ALLIED_OPENCLSALL_1"
.Refresh BackgroundQuery:=False
End With
'Find last used row on the table tab
LR = Workbooks(mBook).Sheets("table").Cells(1, 2).End(xlDown).Row
'Copy data and paste special values onto Changes tab
Workbooks(mBook).Sheets("table").Range("A2:AB" & LR).Copy
Workbooks(mBook).Sheets("Open Closed").Range("A2").PasteSpecial xlPasteValues
'Copy format down to the last row
ActiveWorkbook.Worksheets("Open Closed").Range("A2:AB2").Copy
ActiveWorkbook.Worksheets("Open Closed").Range("A3:AB" & LR).PasteSpecial xlPasteFormats
'Activate Open Closed tab
ActiveWorkbook.Worksheets("Open Closed").Activate
'Name Open Closed tab
Set wsSR = ActiveSheet
'Find last used row on the Open Closed tab
LR = Workbooks(mBook).Sheets("Open Closed").Cells(1, 2).End(xlDown).Row
'Add autofilter
Workbooks(mBook).Worksheets("Open Closed").Range("A1").AutoFilter
'Sort by Parent ID (column B)
ActiveWorkbook.Worksheets("Open Closed").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Open Closed").Sort.SortFields.Add Key:=Range( _
"B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Open Closed").Sort
.SetRange Range("A1:AB" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Create list of all distinct Parent IDs in column AH - to be used in autofilter
ActiveWorkbook.Worksheets("Open Closed").Range("B2", Range("B2").End(xlDown)).Copy Range("AH2")
ActiveWorkbook.Worksheets("Open Closed").Range("AH1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
iLeft = Range("AH1").CurrentRegion.Rows.Count - 1
Do While iLeft > 0
'Get current Parent ID to open appropriate file
PID = wsSR.Range("AH1").Offset(iLeft).Value
'iLeft = iLeft - 1
'Set SRSRVPRC file to add OpenClosed info to
tfile = "\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Monthly Standard Reports\Price and Service Level Changes\"
On Error Resume Next
Set Wb = Workbooks.Open(tfile & Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx")
'Have macro wait until the file opens in full edit mode
Do Until Wb.ReadOnly = False
Application.Wait (Now + TimeValue("00:00:01"))
If Wb Is Nothing Then
Exit Do
End If
Set Wb = Workbooks.Open(tfile & Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx")
Loop
If Wb Is Nothing Then
'Set SRSRVPRC template
tfile = "\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Customer Report Templates\_Templates\"
Workbooks.Open (tfile), False, ReadOnly:=False
Set Tb = Workbooks.Open(tfile & "NB_Price and Service Level Change with open closed containers tab rev.xlsx")
'Have macro wait until the file opens in full edit mode
Do Until Tb.ReadOnly = False
Application.Wait (Now + TimeValue("00:00:01"))
Set Tb = Workbooks.Open(tfile & "NB_Price and Service Level Change with open closed containers tab rev.xlsx")
Loop
tBook = ActiveWorkbook.Name
'Enter message on Service or Price Level Changes tab
Workbooks(tBook).Worksheets("Service or Price Level Changes").Range("A4").Value = "Nothing to report."
'Activate Containers Opened or Closed tab
Workbooks(tBook).Worksheets("Containers Opened or Closed").Activate
Set wsNew = ActiveSheet
'Copy each Parent ID to a separate SRSRVPRC file
With wsSR.Range("B2").CurrentRegion
.AutoFilter field:=2, _
Criteria1:=wsSR.Range("AH1").Offset(iLeft).Value
.Copy Workbooks(tBook).Worksheets("Containers Opened or Closed").Range("A3")
.AutoFilter
End With
'Apply correct formatting to Column Headers
With wsNew.Range("A3:AB3")
.Interior.ThemeColor = xlThemeColorDark2
.Font.Bold = True
.Font.ThemeColor = xlThemeColorDark1
.Font.Name = "Open Sans"
End With
'Resize all columns
Workbooks(tBook).Worksheets(wsNew).Cells.Select
Workbooks(tBook).Worksheets(wsNew).Cells.EntireColumn.AutoFit
'End with cursor on cell A4
Workbooks(tBook).Worksheets(wsNew).Range("A4").Select
Workbooks(tBook).Worksheets(wsNew).Range("A4").Activate
'Path of SRSRVPRC Folder
sDestPath = "\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Monthly Standard Reports\Price and Service Level Changes\"
'Naming convention for new SRSRVPRC
sSaveFilename = Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx"
'Save new SRSRVPRC with naming convention and to the path outlined above
ActiveWorkbook.SaveCopyAs sDestPath & sSaveFilename
'PID = Empty
tfile = Empty
wsNew = Empty
Wb = Empty
Tb = Empty
tBook = Empty
Workbooks(tBook).Close False
Else
'tfile = "\\srazphx24\Share\Division\nat_acct\Reporting\REPORTING ANALYSIS\Monthly Standard Reports\Price and Service Level Changes\" & Year(Date) & "." & Right(("0" & Month(Date)), 2) & "." & Right(("0" & Day(Date)), 2) & " PI " & PID & " Price and Service Level Change.xlsx"
'Open appropriate SRSRVPRC File
'Workbooks.Open (tfile), False, ReadOnly:=False
tBook = ActiveWorkbook.Name
'Activate Open Closed tab
Workbooks(tBook).Worksheets("Containers Opened or Closed").Activate
Set wsNew = ActiveSheet
'Copy each Parent ID to a separate SRSRVPRC file
With wsSR.Range("B2").CurrentRegion
.AutoFilter field:=2, _
Criteria1:=wsSR.Range("AH1").Offset(iLeft).Value
.Copy Workbooks(tBook).Worksheets("Containers Opened or Closed").Range("A3")
.AutoFilter
End With
'Apply correct formatting to Column Headers
With wsNew.Range("A3:AB3")
.Interior.ThemeColor = xlThemeColorDark2
.Font.Bold = True
.Font.ThemeColor = xlThemeColorDark1
.Font.Name = "Open Sans"
End With
'Resize all columns
Workbooks(tBook).Worksheets(wsNew).Cells.Select
Workbooks(tBook).Worksheets(wsNew).Cells.EntireColumn.AutoFit
'End with cursor on cell A3
Workbooks(tBook).Worksheets(wsNew).Range("A4").Select
Workbooks(tBook).Worksheets(wsNew).Range("A4").Activate
'Activate Containers Opened or Closed tab
Worksheets("Service or Price Level Changes").Activate
'Save spreadsheet
ActiveWorkbook.Save
'PID = Empty
tfile = Empty
wsNew = Empty
Workbooks(tBook).Close False
End If
iLeft = iLeft - 1
Loop
Last edited:
