error 9 subscript out of range using excel 365 but not with excel 2010

[cjcaldwell427]

Hi everyone...HELP!

I want to start this with, I do not know VBA code.

I have a macro that gathers much information from many tabs within the same workbook and produces a single report. It works without error using excel 2010 or earlier versions. Using excel 365 I receive error "#9 subscript out of range".

I'll repeat, I do not know VBA code. The person that wrote the macro is no longer available to help. Retired, past on.

Is there something different in excel 365 that would cause earlier versions to error? Maybe the code language changed between versions? I don't just guessing.

I copied and pasted the code from the specific macro for review. It's part of an Addin.

Thanks,
CJ

' modPartReport -bk- - 3/9/15
' 3/9/15 added time stamp to part report
' 3/6/15 added the autofilter criteria to part report header
' revised part report header for long sFilter description
' 11/25/13 suplemented error reporting in gathering data in PartReport()
''[4-19-11] TAGS were nulls ("") - used clearcontents to clear them so macros like SmartTag worked properly.
' 2/9/2011 gave sheet!range reference to DIETABLE since nonactive sheet
' 1/21/2011 avoid looking at headers off the worksheet
' 12/22/2010 code tweaks
' 12/20/2010 fix bug in writing sheet names to -INI-
' 11/22/10 - added Fab Sheet Reports routine
' 11/19/10 - added Material Order Report and Fabsheet Report
' 10-25-10 corrected capability for prefix or suffix on LEN QTY & TAG
' 8/14/10 - added capability to find QTY, LEN, and TAG columns with either spaces or "_" chr
' warns if working with filtered data, all MAIN* sheets must be filtered with same criteria
Option Explicit
'
Private Type Findings
fPartLen As Single
lPartQty As Long
lUnitQty As Long
sColNum As String
sElev As String
sFlr As String
sOption() As String
sPart As String
sPartPage As String
sPartTag As String
sUnitPart As String
sUnitTag As String
End Type
'
Private Type HeaderSheetInfo
lLenHeaderCol As Long
lPartHeaderCol As Long
lQtyHeaderCol As Long
lTagHeaderCol As Long
sMainSheet As String
sPartHeader As String
End Type
'
Private Type OptionalHeaderInfo
sOptHdr As String
lOptionCol As Long
sMainSheet As String
lReportCol As Long
End Type
'
Private Type PartInfo
fMaxLength As Single
fPartWeight As Single
fPerimeter As Single
sDescription As String
sExtrDieNum As String
sPart As String
End Type
'
Global gsPartReportType As String
'
Sub DoPartReport() ' ENTRY >>> LEGACY OBSOLETE USE BUTTON DIRECTED CODE BELOW<<<
OpenProgress ("PartReport")
End Sub
'===============================================================================
Sub btnConsolidated() ' ENTRY
gsPartReportType = "ConsolodatedPartReport"
OpenProgress ("PartReport")
End Sub
'===============================================================================
Sub btnFabSheet() ' ENTRY
gsPartReportType = "FabSheetPartReport"
OpenProgress ("PartReport")
End Sub
'===============================================================================
Sub btnMtlOrder() ' ENTRY
gsPartReportType = "MtlOrderPartReport"
OpenProgress ("PartReport")
End Sub
'==============================================================================
Sub PartReport() ' called from Progress Form [3/6/15 added the autofilter criteria, revised report header for long sFilter]
Dim I As Long, K As Long, P As Long, s As Long, W As Long, X As Long, Y As Long, Z As Long
Dim bHaveDieInfo As Boolean ' TRUE if a dietable has been set up
Dim bHaveQtyCol As Boolean ' TRUE if this part has a QTY Column
Dim bIsFiltered As Boolean ' TRUE if [DataList] is filtered
Dim bMatchedDie As Boolean
Dim bOneDie As Boolean ' TRUE if just one die is being reported on
Dim ColRng As Range
Dim dAccumFeet As Double
Dim dAccumWeight As Double
Dim ErrMsg As String
Dim FirstAddress As String
Dim FndObj As Object
Dim lAccumQty As Long
Dim lCalcMode As Long
Dim lDBcols As Long ' [DataList]
Dim lDBrows As Long ' [DataList]
Dim lDescCol As Long ' Dies Table
Dim lDieCol As Long ' Dies Table
Dim lFound As Long ' [DataList]
Dim lFrow As Long
Dim lFwd As Long ' the number of columns to search fwd for QTY or TAG columns
Dim lHdrCol As Long
Dim lNumDies As Long ' Dies Table
Dim lNumHdrs As Long ' HDRCRITERIA
Dim lNumOptHdrs As Long ' the number of optional headers specified
Dim lNumParts As Long ' number of parts to find for report
Dim lNumRows As Long ' [DataList]
Dim lNumSheets As Long ' number of MAIN sheets on which sFindParts() are found
Dim lOptHdrCount As Long ' the number of optional headers found all all sheets
Dim lProcCntr As Long
Dim lRptVals As Long ' lNumHdrs * lDBrows
Dim lWeightCol As Long ' Dies Table
Dim lZCon As Long ' FoundArr(lZCon)
Dim OptHdrs() As OptionalHeaderInfo
Dim OptHeaders() As String ' the array of the optional header titles listed
Dim ReportData() As Findings
Dim rngAttribCol As Range
Dim rngDies As Range ' [DIES!DIETABLE]
Dim rngTemp As Range
Dim sFilter As String ' the autofilter on MAIN datalist
Dim sFindPart As String ' "DIE_LIST","ONE_PART","DIES","ALL"
Dim sFindParts() As String ' array of all the parts listed to be reported on
Dim SheetNames() As String
Dim sReportTitle As String ' from INI Project Name and [PrtRptTitle]
Dim sShtGroup As String
Dim sTemp As String
Dim sTemp1 As String
Dim sTemp2 As String
Dim sWbook As String ' the current active project spreadsheet
Dim WSrng As Range ' the current worksheet.[DataList]
'
bHaveDieInfo = True: bOneDie = False
If Not IsValidXsht Then GoTo Xit
On Error Resume Next
gsErrMsg = "" ' [11/25/13]
Worksheets("Part Report").Activate
If Err Then
ErrMsg = "Can't Find Worksheet Part Report."
GoTo ERRhandle
End If
sWbook = ActiveWorkbook.Name
lNumOptHdrs = Sheets("Part Report").[PrtRptOptHdrs].CurrentRegion.Rows.Count - 1
If Err Then
ErrMsg = "Can't Find Named Range [PrtRptOptHdrs] on Worksheet Part Report."
GoTo ERRhandle
End If
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
'Set rngDies = Sheets("DIES").[DieTable].CurrentRegion
Set rngDies = Range("DIES!DIETABLE").CurrentRegion '[2-9-11] nonactive sheet reference
If Err Then bHaveDieInfo = False: Err.Clear
Call UpdateProgress(5, "Get Criteria...")
DoEvents
'----read Optional Headers if any------
ReDim OptHeaders(lNumOptHdrs)
For X = 1 To lNumOptHdrs
sTemp = Trim$(Sheets("Part Report").[PrtRptOptHdrs].Cells(X + 1, 1))
If Len(sTemp) > 0 Then OptHeaders(X) = sTemp
Next
'----read Dies if any------
lNumParts = Sheets("Part Report").[PrtRptDies].CurrentRegion.Rows.Count - 1
If Err Then
ErrMsg = "Can't Find named Range [PrtRptDies] on Worksheet Part Report."
GoTo ERRhandle
End If
ReDim sFindParts(lNumParts)
For X = 1 To lNumParts
sTemp = UCase$(Trim$(Sheets("Part Report").[PrtRptDies].Cells(X + 1, 1)))
If Len(sTemp) > 0 Then sFindParts(X) = sTemp
Next
Select Case lNumParts
Case 0
sFindPart = "ALL"
lNumParts = 1
ReDim sFindParts(lNumParts)
Case 1
Select Case UCase$(sFindParts(1))
Case "ALL"
sFindPart = "ALL"
Case "DIES"
sFindPart = "DIES"
Case Else
sFindPart = "ONE_PART"
bOneDie = True
End Select
Case Else
sFindPart = "DIE_LIST"
End Select
' limit the number of workbooks generated by Fabsheet Reports to 12.
If gsPartReportType = "FabSheetPartReport" Then
sTemp = ""
If sFindPart = "ALL" Or sFindPart = "DIES" Or sFindPart = "DIE_LIST" Then
If sFindPart = "DIE_LIST" Then
If lNumParts > 12 Then
sTemp = "Do not list more than 12 dies for Fabsheet Reports."
End If
Else ' no list
sTemp = "Please list from 1 to 12 dies for Fabsheet Reports."
End If 'sFindPart = "DIE_LIST"
If sTemp <> "" Then
MsgBox sTemp, vbExclamation, "MK Spreadsheet"
GoTo Xit
End If
End If 'sFindPart = "ALL"
End If 'gsPartReportType = "FabSheetPartReport"
'----Read Report Title------
sReportTitle = Sheets("INI").[PROJECT_NAME].Value
If Err Then Err.Clear ' not fatal, continue
sReportTitle = sReportTitle & " " & Trim$(Sheets("Part Report").[PrtRptTitle].Cells(2, 1))
If Err Then
Call MsgBox("Can't Find named Range [PrtRptTitle] on Worksheet Part Report.", vbInformation, "MK Spreadsheet")
Err.Clear ' not fatal, continue
End If
' find valid MAIN sheets ( with LEN columns ) and has the part if specified
lNumSheets = DetermineMains(SheetNames(), sFindPart, sFindParts())
If lNumSheets = 0 Then
ErrMsg = "Nothing Found in any of the Main Datasheets."
Call MsgBox(ErrMsg, vbInformation, "MK Spreadsheet")
GoTo Xit
End If
' look for filtered data on found sheets and see that they are filtered the same
Select Case FilteredRows(SheetNames())
Case "Filtered All Same"
ErrMsg = "Data is Filtered or has Hidden Rows on " & SheetNames(1) & vbCrLf & _
"Do you want to report on filtered data?"
X = MsgBox(ErrMsg, vbQuestion Or vbYesNo, "Part Report")
If X = 7 Then ' cancel op
GoTo Xit
End If
bIsFiltered = True
Case "Filtered Not Same"
For X = 1 To lNumSheets
sShtGroup = sShtGroup & " " & SheetNames(X)
Next
ErrMsg = "Filtered data is not applied the same on " & sShtGroup
GoTo ERRhandle
Case "Not Filtered"
'DB "Not Filtered" 'proceed
Case Else
'DB "Case else"
End Select
ErrMsg = ""
If bIsFiltered Then sFilter = GetAutoFilter("MAIN")
'DB bIsFiltered, "sfilter: ", sFilter
DoEvents
If bHaveDieInfo = True Then
Call UpdateProgress(10, "Gathering Die Info...")
sTemp = ""
lNumDies = rngDies.Rows.Count - 1
ReDim DiesInfo(lNumDies) As PartInfo
Set rngTemp = Range(rngDies.Cells(1, 1), rngDies.Cells(1, rngDies.Columns.Count))
lDieCol = FindHdrCol(rngTemp, "DIE")
If lDieCol = 0 Then ErrMsg = "Can't find Dies Table DIE column"
lWeightCol = FindHdrCol(rngTemp, "WEIGHT")
If lWeightCol = 0 Then ErrMsg = "Can't find Dies Table WEIGHT column"
lDescCol = FindHdrCol(rngTemp, "DESCRIPTION")
If lDescCol = 0 Then ErrMsg = "Can't find Dies Table DESCRIPTION column"
If Len(ErrMsg) > 0 Then
Call MsgBox(ErrMsg, vbInformation, "MK Spreadsheet")
Err.Clear ' non fatal, continue
End If
For X = 1 To lNumDies
DiesInfo(X).sPart = rngDies.Cells(X + 1, lDieCol).Value
DiesInfo(X).fPartWeight = rngDies.Cells(X + 1, lWeightCol).Value
DiesInfo(X).sDescription = rngDies.Cells(X + 1, lDescCol).Value
Next X
End If
If sFindPart = "DIES" And bHaveDieInfo = False Then
ErrMsg = "Can't find [DieTable] on sheet DIES."
GoTo ERRhandle
End If
If sFindPart = "DIES" Then
ReDim sFindParts(lNumDies)
lNumParts = lNumDies
For X = 1 To lNumDies
sFindParts(X) = DiesInfo(X).sPart
Next
End If
Application.ScreenUpdating = False
Application.EnableCancelKey = xlErrorHandler
UpdateProgress 15, "Gathering Optional Headers..."
ErrMsg = "Gathering Optional Headers"
lDBrows = Worksheets(SheetNames(1)).[DATALIST].CurrentRegion.Rows.Count
' get info for Optional Headers on found sheets
lOptHdrCount = 0
For X = 1 To lNumOptHdrs
For W = 1 To lNumSheets
Set WSrng = Worksheets(SheetNames(W)).[DATALIST]
Set rngTemp = Range(WSrng.Cells(1, 1), WSrng.Cells(1, WSrng.Columns.Count))
sTemp = OptHeaders(X)
Z = FindHdrCol(rngTemp, sTemp)
If Z > 0 Then
lOptHdrCount = lOptHdrCount + 1
ReDim Preserve OptHdrs(lOptHdrCount)
OptHdrs(lOptHdrCount).sOptHdr = OptHeaders(X)
OptHdrs(lOptHdrCount).lOptionCol = Z
OptHdrs(lOptHdrCount).sMainSheet = SheetNames(W)
OptHdrs(lOptHdrCount).lReportCol = X
End If
Next ' W lNumSheets
Next 'x lOptHdrCount
DoEvents
' --------------------------------------------------------------------------------
' get valid headers (with LEN). If onedie, then headers that have this part
UpdateProgress 20, "Finding Headers..."
ErrMsg = "Finding Headers"
On Error GoTo ERRhandle
lNumHdrs = 0
Dim ShtHdrInfo() As HeaderSheetInfo
I = 0
For s = 1 To lNumSheets
Set WSrng = Worksheets(SheetNames(s)).[DATALIST]
lDBcols = WSrng.CurrentRegion.Columns.Count
If sFindPart = "ALL" Or sFindPart = "DIES" Or sFindPart = "DIE_LIST" Then
For Y = 1 To lDBcols
' look for LEN columns then look backward for group header,
' then look fwd for QTY and TAG column
sTemp1 = UCase$(WSrng.Cells(1, Y).Value)
If InStr((Right$(Trim$(sTemp1), 4)), " LEN") Or _
InStr((Right$(Trim$(sTemp1), 4)), "_LEN") Or _
InStr((Left$(Trim$(sTemp1), 4)), "LEN ") Or _
InStr((Left$(Trim$(sTemp1), 4)), "LEN_") Then
'found a LEN column now search for main header and QTY and TAG columns
For Z = 1 To 6
sTemp2 = UCase$(WSrng.Cells(1, Y - Z).Value)
If sTemp2 = Left$(sTemp1, Len(sTemp1) - 4) Or _
sTemp2 = Right$(sTemp1, Len(sTemp1) - 4) Then
' found a main header with a LEN column
I = I + 1
ReDim Preserve ShtHdrInfo(I) As HeaderSheetInfo
lHdrCol = Y - Z
ShtHdrInfo(I).sMainSheet = SheetNames(s)
ShtHdrInfo(I).sPartHeader = sTemp2
ShtHdrInfo(I).lPartHeaderCol = lHdrCol
ShtHdrInfo(I).lLenHeaderCol = Y
lFwd = 6
If lHdrCol > (lDBcols - lFwd) Then
lFwd = lDBcols - lHdrCol 'avoid looking at cells off the worksheet
End If
For X = 1 To lFwd
sTemp1 = UCase$(Trim$(WSrng.Cells(1, lHdrCol + X).Value))
If sTemp1 = sTemp2 & " QTY" Or _
sTemp1 = sTemp2 & "_QTY" Or _
sTemp1 = "QTY " & sTemp2 Or _
sTemp1 = "QTY_" & sTemp2 Then
ShtHdrInfo(I).lQtyHeaderCol = lHdrCol + X
End If
If sTemp1 = sTemp2 & " TAG" Or _
sTemp1 = sTemp2 & "_TAG" Or _
sTemp1 = "TAG " & sTemp2 Or _
sTemp1 = "TAG_" & sTemp2 Then
ShtHdrInfo(I).lTagHeaderCol = lHdrCol + X
End If
Next 'x
Exit For
End If
Next 'Z
End If 'InStr(" LEN")
Next 'Y lDBcols
Else ' then find one part
lNumRows = WSrng.Rows.Count
For Y = 1 To lDBcols
Set rngAttribCol = Range(WSrng.Cells(1, Y), Worksheets(SheetNames(s)).[DATALIST].Cells(lNumRows, Y))
lFound = CountIt(rngAttribCol, sFindParts(1))
If lFound > 0 Then
'found the main header now search for LEN column and QTY column
I = I + 1
ReDim Preserve ShtHdrInfo(I) As HeaderSheetInfo
lHdrCol = Y
ShtHdrInfo(I).sMainSheet = SheetNames(s)
sTemp1 = UCase$(WSrng.Cells(1, lHdrCol))
ShtHdrInfo(I).sPartHeader = sTemp1
ShtHdrInfo(I).lPartHeaderCol = lHdrCol
For Z = 1 To 6
sTemp2 = UCase$(Trim$(WSrng.Cells(1, Y + Z).Value))
If sTemp2 = sTemp1 & " LEN" Or _
sTemp2 = sTemp1 & "_LEN" Or _
sTemp2 = "LEN " & sTemp1 Or _
sTemp2 = "LEN_" & sTemp1 Then
ShtHdrInfo(I).lLenHeaderCol = lHdrCol + Z
Exit For
End If '= sTemp1 & " LEN"
Next 'Z
' if no len found then fatal stop
If ShtHdrInfo(I).lLenHeaderCol = 0 Then
ErrMsg = "Can't find LEN column for < " & sTemp1 & " >"
GoTo ERRhandle
End If
lFwd = 6
If lHdrCol > (lDBcols - lFwd) Then
lFwd = lDBcols - lHdrCol 'avoid looking at cells off the worksheet
End If
For Z = 1 To lFwd ' QTY column is optional. OK if not found
sTemp2 = UCase$(Trim$(WSrng.Cells(1, Y + Z).Value))
If sTemp2 = sTemp1 & " QTY" Or _
sTemp2 = sTemp1 & "_QTY" Or _
sTemp2 = "QTY " & sTemp1 Or _
sTemp2 = "QTY_" & sTemp1 Then
ShtHdrInfo(I).lQtyHeaderCol = lHdrCol + Z
bHaveQtyCol = True
End If '= sTemp1 & " QTY"
If sTemp2 = sTemp1 & " TAG" Or _
sTemp2 = sTemp1 & "_TAG" Or _
sTemp2 = "TAG " & sTemp1 Or _
sTemp2 = "TAG_" & sTemp1 Then
ShtHdrInfo(I).lTagHeaderCol = lHdrCol + Z
End If '= sTemp1 & " TAG"
Next 'Z
End If 'lFound > 0
Next 'Y lDBcols
End If 'sFindPart = "ALL"
Next 'S sheet
lNumHdrs = I
UpdateProgress 33, "Gathering Data..."
ErrMsg = "Gathering Data"
' -------------------------gather data --------------------------------------------------------------------
I = 0
On Error GoTo ERRhandle
For P = 1 To lNumParts
For Y = 1 To lNumHdrs
Set WSrng = Worksheets(ShtHdrInfo(Y).sMainSheet).[DATALIST]
Set ColRng = Range(WSrng.Cells(2, ShtHdrInfo(Y).lPartHeaderCol), WSrng.Cells(lDBrows, ShtHdrInfo(Y).lPartHeaderCol))
With ColRng
If sFindPart = "ALL" Then
Set FndObj = .Find("*", LookIn:=xlValues, LookAt:=xlWhole)
Else
Set FndObj = .Find(sFindParts(P), LookIn:=xlValues, LookAt:=xlWhole)
End If
If Not FndObj Is Nothing Then
FirstAddress = FndObj.Address
Do
On Error Resume Next
sTemp = FndObj.Value
If Err Then
Err.Clear
Else
On Error GoTo ERRhandle
If Len(sTemp) > 0 Then
If sFindPart = "DIES" Then
bMatchedDie = False
For K = 1 To lNumDies
If DiesInfo(K).sPart = sTemp Then
bMatchedDie = True
Exit For
End If
Next
End If
If sFindPart = "DIES" And bMatchedDie = False Then GoTo SkipPart
If (sFindPart = "ALL" Or sFindPart = "DIES" Or sTemp = sFindParts(P)) Then
I = I + 1
ReDim Preserve ReportData(I) As Findings
ReportData(I).sPart = sTemp
ReportData(I).sUnitPart = ShtHdrInfo(Y).sPartHeader
lFrow = FndObj.Row - WSrng.Row + 1
If ShtHdrInfo(Y).lLenHeaderCol > 0 Then
If IsError(WSrng.Cells(lFrow, ShtHdrInfo(Y).lLenHeaderCol).Value) Then ' [11/25/13]
ErrMsg = "Cell Error for Length " & ShtHdrInfo(Y).sPartHeader & " Row:" & _
Str$(lFrow + WSrng.Row - 1) & " Col:" & _
Str$(ShtHdrInfo(Y).lLenHeaderCol) & _
" on sheet " & ShtHdrInfo(Y).sMainSheet
GoTo ERRhandle
End If
On Error Resume Next
ReportData(I).fPartLen = WSrng.Cells(lFrow, ShtHdrInfo(Y).lLenHeaderCol).Value
If Err Then
ErrMsg = ErrMsg & " Got value of: " & WSrng.Cells(lFrow, ShtHdrInfo(Y).lLenHeaderCol).Value & " but expected a numerical value at Row: " & _
Str$(lFrow + WSrng.Row - 1) & ", Column: " & Str$(ShtHdrInfo(Y).lLenHeaderCol)
GoTo ERRhandle
End If
On Error GoTo ERRhandle
End If
If ShtHdrInfo(Y).lTagHeaderCol > 0 Then
ReportData(I).sPartTag = WSrng.Cells(lFrow, ShtHdrInfo(Y).lTagHeaderCol).Value
End If
If ShtHdrInfo(Y).lQtyHeaderCol > 0 Then ' [11/25/13]
If IsError(WSrng.Cells(lFrow, ShtHdrInfo(Y).lQtyHeaderCol).Value) Then
ErrMsg = "Cell Error for Quantity " & ShtHdrInfo(Y).sPartHeader & " Row:" & _
Str$(lFrow + WSrng.Row - 1) & " Col:" & _
Str$(ShtHdrInfo(Y).lQtyHeaderCol) & _
" on sheet " & ShtHdrInfo(Y).sMainSheet
GoTo ERRhandle
End If
On Error Resume Next
ReportData(I).lPartQty = WSrng.Cells(lFrow, ShtHdrInfo(Y).lQtyHeaderCol).Value
If Err Then
ErrMsg = ErrMsg & " Got value of: " & WSrng.Cells(lFrow, ShtHdrInfo(Y).lQtyHeaderCol).Value & " but expected a numerical value at Row: " & _
Str$(lFrow + WSrng.Row - 1) & ", Column: " & Str$(ShtHdrInfo(Y).lQtyHeaderCol)
GoTo ERRhandle
End If
On Error GoTo ERRhandle
End If
ReportData(I).sUnitTag = WSrng.Cells(lFrow, 5).Value
ReportData(I).sFlr = WSrng.Cells(lFrow, 2).Value
ReportData(I).sElev = WSrng.Cells(lFrow, 3).Value
ReportData(I).sColNum = WSrng.Cells(lFrow, 4).Value
ReDim ReportData(I).sOption(lOptHdrCount)
For Z = 1 To lOptHdrCount
If OptHdrs(Z).sMainSheet = ShtHdrInfo(Y).sMainSheet Then
ReportData(I).sOption(Z) = _
WSrng.Cells(lFrow, OptHdrs(Z).lOptionCol).Value
End If '.sMainSheet
Next 'Z lOptHdrCount
End If ' sFindPart = "" Or sTempPart = sFindPart
SkipPart:
End If 'sTemp <> ""

End If 'err
Set FndObj = .FindNext(FndObj)
Loop While Not FndObj Is Nothing And FndObj.Address <> FirstAddress
Else
'DBF sFindParts(P), " Not Found Y=", Y
End If 'If Not FndObj Is Nothing
End With
lProcCntr = lProcCntr + 1
If lProcCntr Mod 7 = 0 Then
Call UpdateProgress((lProcCntr / (lNumHdrs * lNumParts)) * 30 + 31, "Gathering Data...")
End If
Next 'Y lNumHdrs
DoEvents
Next 'P lNumParts
Call UpdateProgress(71, "Building Results Workbook...")
lRptVals = I
If lRptVals = 0 Then
ErrMsg = "No Entries Found"
GoTo ERRhandle
End If
If lRptVals > 65535 Then
ErrMsg = "Too Many Entries Found to Fit on a Spreadsheet (65,535 rows)." & vbCrLf _
& "Report on Less Parts or Filter the Main Datalist."
GoTo ERRhandle
End If
'-------------------------------------------------------------------------------
' Build Report
'-------------------------------------------------------------------------------
ErrMsg = "Build Report "
On Error GoTo ERRhandle
Workbooks.Add
Sheets.Add.Name = "-INI-"
Cells(1, 1) = sWbook
For X = 1 To lNumSheets
Cells(1 + X, 1) = SheetNames(X)
Next 'X
Sheets("-INI-").Move before:=Sheets(1)
Sheets("-INI-").Visible = xlSheetHidden
Sheets("Sheet2").Name = "CONSOLIDATED"
Sheets("Sheet1").Name = "PARTS"
Sheets("PARTS").Activate
Range("A:A").NumberFormat = "@"
Range("E:F").NumberFormat = "@"
ErrMsg = "Build Report Create Headers"
' create headers
If bHaveQtyCol Or sFindPart = "ALL" Or sFindPart = "DIES" Or sFindPart = "DIE_LIST" Then
bHaveQtyCol = True
Range("A1:J1").Value = _
Array("PART", "UNIT PART", "CUT LENGTH", "UNIT TAG", "TAG", "FAB PAGE", _
"QTY", "FLR", "ELV", "NUM")
For X = 1 To lNumOptHdrs
Cells(1, 10 + X).Value = OptHeaders(X)
Next 'X lOptHdrCount
Cells(1, 10 + lNumOptHdrs + 1).Value = "COMMENTS"
Else ' no QTY column
Range("A1:I1").Value = _
Array("PART", "UNIT PART", "CUT LENGTH", "UNIT TAG", "TAG", "FAB PAGE", _
"FLR", "ELV", "NUM")
For X = 1 To lNumOptHdrs
Cells(1, 9 + X).Value = OptHeaders(X)
Next 'X lOptHdrCount
Cells(1, 9 + lNumOptHdrs + 1).Value = "COMMENTS"
End If 'bHaveQtyCol Or sFindPart = "ALL"
Call UpdateProgress(83, "Writing Results...")
' insert data
ErrMsg = "Build Report Insert Data"
If bHaveQtyCol Or sFindPart = "ALL" Then
For X = 1 To lRptVals
Range(Cells(X + 1, 1), Cells(X + 1, 10)).Value = _
Array(ReportData(X).sPart, ReportData(X).sUnitPart, ReportData(X).fPartLen, _
ReportData(X).sUnitTag, ReportData(X).sPartTag, "", _
ReportData(X).lPartQty, ReportData(X).sFlr, _
ReportData(X).sElev, ReportData(X).sColNum)
If ReportData(X).lPartQty = 0 Then Cells(X + 1, 7).Value = 1
If Len(ReportData(X).sPartTag) = 0 Then Cells(X + 1, 5).ClearContents '[4-19-11]
For Z = 1 To lOptHdrCount 'OptHdrs(lOptHdrCount).lReportCol
If ReportData(X).sOption(Z) <> "" Then
Cells(X + 1, 10 + OptHdrs(Z).lReportCol).Value = ReportData(X).sOption(Z)
End If
Next 'Z lOptHdrCount
Next 'X lRptVals
Else ' no QTY column
For X = 1 To lRptVals
Range(Cells(X + 1, 1), Cells(X + 1, 9)).Value = _
Array(ReportData(X).sPart, ReportData(X).sUnitPart, ReportData(X).fPartLen, _
ReportData(X).sUnitTag, ReportData(X).sPartTag, "", _
ReportData(X).sFlr, ReportData(X).sElev, ReportData(X).sColNum)
If Len(ReportData(X).sPartTag) = 0 Then Cells(X + 1, 5).ClearContents '[4-19-11]
For Z = 1 To lOptHdrCount
If ReportData(X).sOption(Z) <> "" Then
Cells(X + 1, 9 + OptHdrs(Z).lReportCol).Value = ReportData(X).sOption(Z)
End If
Next 'Z lOptHdrCount
Next 'X lRptVals
End If 'bHaveQtyCol Or sFindPart = "ALL"
'sort by PART then by CUT LENGTH
ErrMsg = "Sorting Data for Consolidation"
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("C1"), Order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Columns("A:AZ").HorizontalAlignment = xlCenter
Range("1:1").Font.Bold = True
Range("C:C").NumberFormat = "# ??/??"
'-----consolidate data on partsheet---------
ErrMsg = "Consolidating Main Data "
Call UpdateProgress(91, "Consolidating...")
ReDim FoundArr(lRptVals) As Findings
lZCon = 0
FoundArr(0).sPart = ""
FoundArr(0).lUnitQty = 0
FoundArr(0).fPartLen = 0
For I = 1 To lRptVals
If Not IsEmpty(Cells(I + 1, 1).Value) Then
If Cells(I + 1, 3).Value = FoundArr(lZCon).fPartLen And _
Cells(I + 1, 1).Value = FoundArr(lZCon).sPart Then
FoundArr(lZCon).sPart = Cells(I + 1, 1).Value
If bHaveQtyCol Or sFindPart = "ALL" Then
FoundArr(lZCon).lUnitQty = FoundArr(lZCon).lUnitQty + Cells(I + 1, 7).Value
Else
FoundArr(lZCon).lUnitQty = FoundArr(lZCon).lUnitQty + 1
End If
FoundArr(lZCon).fPartLen = Cells(I + 1, 3).Value
Else
lZCon = lZCon + 1
FoundArr(lZCon).sPart = Cells(I + 1, 1).Value
If bHaveQtyCol Or sFindPart = "ALL" Then
FoundArr(lZCon).lUnitQty = FoundArr(lZCon).lUnitQty + Cells(I + 1, 7).Value
Else
FoundArr(lZCon).lUnitQty = FoundArr(lZCon).lUnitQty + 1
End If
FoundArr(lZCon).fPartLen = Cells(I + 1, 3).Value
End If
End If ' ISEMPTY
Next I
Columns("A:AZ").Columns.AutoFit
Columns("A:AZ").Columns.AutoFit
With ActiveSheet.PageSetup
.LeftHeader = "&D"
.RightHeader = "&P of &N"
.TopMargin = Application.InchesToPoints(0.65)
.BottomMargin = Application.InchesToPoints(0.65)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = True
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
End With
X = Range("A1").CurrentRegion.Columns.Count
Range(Cells(1, 1), Cells(1, X)).Borders(xlEdgeBottom).LineStyle = xlContinuous
Call UpdateProgress(91, "Formating Results Workbook...")
'------------- build consolidated report ------------
ErrMsg = "Build Consolidated Report. "
Sheets("CONSOLIDATED").Select
'Cells(1, 1).Value = Date & " " & Format(Time, "HH:MM") & " CONSOLIDATED REPORT "
'If bIsFiltered Then Cells(1, 1).Value = Cells(1, 1).Value & "ON FILTERED DATA " & sFilter
Cells(1, 1).Value = Date & " - " & Format(Time, "HH:MM") ' [3/9/15]
If bIsFiltered Then Cells(1, 1).Value = Cells(1, 1).Value & " - FILTERED " & sFilter
Cells(2, 1).Value = sReportTitle
If bOneDie Then
For X = 1 To lNumDies ' ( if lNumDies= 0 then No Die List, this is skipped)
If DiesInfo(X).sPart = FoundArr(1).sPart Then
Cells(3, 1).Value = DiesInfo(X).sDescription & " WT/FT=" & DiesInfo(X).fPartWeight
Exit For
End If
Next 'X
End If
Range("A:A").NumberFormat = "@"
Range("C:C").NumberFormat = "@"
Cells(5, 1).Value = "PART"
Cells(5, 2).Value = "CUT LEN"
Cells(5, 3).Value = "TAG"
Cells(5, 4).Value = "QTY"
Cells(5, 5).Value = "FEET"
Cells(5, 6).Value = "WEIGHT"
For I = 1 To lZCon
Cells(I + 5, 1).Value = FoundArr(I).sPart
Cells(I + 5, 2).Value = FoundArr(I).fPartLen
Cells(I + 5, 4).Value = FoundArr(I).lUnitQty
lAccumQty = lAccumQty + Cells(I + 5, 4).Value
Cells(I + 5, 5).Value = (Cells(I + 5, 2).Value / 12) * Cells(I + 5, 4).Value
dAccumFeet = dAccumFeet + Cells(I + 5, 5).Value
If bHaveDieInfo Then
For X = 1 To lNumDies
If DiesInfo(X).sPart = Cells(I + 5, 1).Value Then
Cells(I + 5, 6).Value = Cells(I + 5, 5).Value * DiesInfo(X).fPartWeight
dAccumWeight = dAccumWeight + Cells(I + 5, 6).Value
Exit For
End If 'DIESINFO(X).PART = Cells(I + 5, 1).Value
Next X
End If ' HAVEDIEINFO
Next I
Cells(I + 5 + 1, 4).Value = lAccumQty
Cells(I + 5 + 1, 5).Value = dAccumFeet
If bHaveDieInfo Then
Cells(I + 5 + 1, 6).Value = dAccumWeight
End If 'HAVEDIEINFO
Columns("A:A").ColumnWidth = 11.5
Columns("B:M").Columns.AutoFit
Columns("A:G").HorizontalAlignment = xlCenter
Range("A1:F5").Font.Bold = True
Range("A1:F5").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("B:B").NumberFormat = "# ??/??"
Range("D:D").NumberFormat = "0"
Range("E:E").NumberFormat = "0.00"
Range("E:E").HorizontalAlignment = xlRight
Range("F:F").NumberFormat = "0.0"
Columns("E:F").Style = "Comma"
Range("F:F").HorizontalAlignment = xlRight
Range("A1").HorizontalAlignment = xlLeft
Range("A2").HorizontalAlignment = xlLeft
Range("A3").HorizontalAlignment = xlLeft
Range("A1").Select
Select Case gsPartReportType
Case "ConsolodatedPartReport"
GoTo Xit
Case "FabSheetPartReport"
GoTo FabSheetReports
Case "MtlOrderPartReport"
GoTo MtlOrderPartReport
Case Else
GoTo Xit
End Select
GoTo Xit
MtlOrderPartReport:
gsErrMsg = "Creating Material Order Tabs..."
DoMtlOrderReportTabs DiesInfo()
GoTo Xit
FabSheetReports:
If bOneDie = False Then
gsErrMsg = "Creating Fab Sheet Reports..."
DoFabReports DiesInfo()
DB ErrMsg
End If
GoTo Xit
ERRhandle:
Unload frmProgress
DoEvents
If Err = 18 Then Err.Clear: GoTo Xit ' User Cancelled During Operation
ErrReport ErrMsg & gsErrMsg & vbCrLf & vbTab & "Error in MK_XLA_Project Module modPartReport Sub PartReport."

Err.Clear
Xit:
Unload frmProgress
Application.Calculation = lCalcMode
Set rngDies = Nothing
Set rngTemp = Nothing
Set WSrng = Nothing
Set rngAttribCol = Nothing
Set ColRng = Nothing
Set FndObj = Nothing
DB "End PartReport"
End Sub 'PartReport
'===============================================================================
Private Sub DoMtlOrderReportTabs(DiesInfo() As PartInfo)
Dim X As Long, Y As Long, Z As Long
Dim dAccumFeet As Double ' total feet fo this part
Dim dAccumWt As Double ' total weight
Dim lAccumQty As Long ' total weight for this part
Dim lNumCols As Long ' number of columns in the main consolidated table
Dim lNumParts As Long ' the number of unique parts in the main consolidated table
Dim lNumRows As Long ' number of rows in the main consolidated table
Dim lRow As Long ' the current row of the part table on the current part tab
Dim PartAry() As String ' the array of parts from the main consolidated table
Dim rngHeader As Range ' the header from the main consolidated table
Dim sPart As String ' the current part
Dim sPrevPart As String ' test if a new part vs prev part
Dim vHdr
' the array of the header from the main consolidated table to transfer to tabs
'
gsErrMsg = "DoMtlOrderReportTabs Parsing Consolidated Main Data"
Call UpdateProgress(95, "Parsing Consolidated Main Data... ")
DoEvents
Sheets("CONSOLIDATED").Select
Set rngHeader = Range(Cells(1, 1), Cells(5, 11))
vHdr = rngHeader
lNumRows = Cells(5, 1).CurrentRegion.Rows.Count - 1
lNumCols = Cells(5, 1).CurrentRegion.Columns.Count
'DB lNumRows, "lNumRows"
ReDim PartAry(lNumRows, lNumCols) As String
' get info from Consolidated Table
For Y = 1 To lNumRows
For X = 1 To lNumCols
PartAry(Y, X) = Cells(5 + Y, X).Value
Next
Next
gsErrMsg = "DoMtlOrderReportTabs Creating New Report Tabs"
For Y = 1 To lNumRows
sPart = PartAry(Y, 1)
If sPart <> sPrevPart Then ' create new tab and list parts
'first format previous tab and insert totals
If Y > 1 Then
GoSub FormatTab
lRow = lRow + 2
Cells(lRow, 4).Value = lAccumQty
Cells(lRow, 5).Value = dAccumFeet
Cells(lRow, 6).Value = dAccumWt
Columns("B:M").Columns.AutoFit
End If
lRow = 6
lAccumQty = 0: dAccumFeet = 0: dAccumWt = 0
gsErrMsg = "Consolidating Main Data. Creating New Worksheet " & sPart
Sheets.Add.Name = sPart
Sheets(sPart).Move After:=Sheets(Sheets.Count)
Sheets(sPart).Tab.ColorIndex = 1
Sheets(sPart).PageSetup.FitToPagesWide = 1
Sheets(sPart).PageSetup.FitToPagesTall = False
Sheets(sPart).Range(Cells(1, 1), Cells(5, 11)) = vHdr
Sheets(sPart).Range(Cells(1, 1), Cells(5, 11)).Font.Bold = True
For Z = 1 To UBound(DiesInfo())
If PartAry(Y, 1) = DiesInfo(Z).sPart Then
Cells(3, 1).Value = DiesInfo(Z).sDescription & " WT/FT=" & Str$(DiesInfo(Z).fPartWeight)
Exit For
End If
Next 'Z
For X = 1 To lNumCols
Cells(lRow, X).Value = PartAry(Y, X)
If X = 4 Then lAccumQty = lAccumQty + Val(PartAry(Y, X))
If X = 5 Then dAccumFeet = dAccumFeet + Val(PartAry(Y, X))
If X = 6 Then dAccumWt = dAccumWt + Val(PartAry(Y, X))
Next 'x
sPrevPart = sPart
Else ' same part so list on existing tab
lRow = lRow + 1
For X = 1 To lNumCols
Cells(lRow, X).Value = PartAry(Y, X)
If X = 4 Then lAccumQty = lAccumQty + Val(PartAry(Y, X))
If X = 5 Then dAccumFeet = dAccumFeet + Val(PartAry(Y, X))
If X = 6 Then dAccumWt = dAccumWt + Val(PartAry(Y, X))
Next 'x
End If
Next 'Y
'format LAST tab
GoSub FormatTab
'add totals to LAST tab
lRow = lRow + 2
Cells(lRow, 4).Value = lAccumQty
Cells(lRow, 5).Value = dAccumFeet
Cells(lRow, 6).Value = dAccumWt
Columns("B:M").Columns.AutoFit
GoTo Xit
FormatTab:
Columns("A:A").ColumnWidth = 11.5
Columns("B:M").Columns.AutoFit
Columns("A:G").HorizontalAlignment = xlCenter
Range("A1:F5").Font.Bold = True
Range("A1:F5").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("B:B").NumberFormat = "# ??/??"
Range("D:D").NumberFormat = "0"
Range("E:E").NumberFormat = "0.00"
Range("E:E").HorizontalAlignment = xlRight
Range("F:F").NumberFormat = "0.0"
Columns("E:F").Style = "Comma"
Range("F:F").HorizontalAlignment = xlRight
Range("A1").HorizontalAlignment = xlLeft
Range("A2").HorizontalAlignment = xlLeft
Range("A3").HorizontalAlignment = xlLeft
Range("A1").Select
Return
Xit:
Unload frmProgress
DoEvents
Set rngHeader = Nothing
End Sub
'===============================================================================
Private Sub DoFabReports(DiesInfo() As PartInfo)
Dim I As Long, J As Long, X As Long, Y As Long, Z As Long
Dim dAccumFeet As Double ' total feet fo this part
Dim dAccumWt As Double ' total weight
Dim lAccumQty As Long ' total weight for this part
Dim lNumCols As Long ' number of columns in the main consolidated table
Dim lNumParts As Long ' the number of unique parts in the main consolidated table
Dim lNumPcCols As Long ' number of Cols in the main PARTS list
Dim lNumPcRows As Long ' number of Rows in the main PARTS list
Dim lNumRows As Long ' number of rows in the main consolidated table
Dim lPcRow As Long ' the current row of the parts list in the current part WB
Dim lRow As Long ' the current row of the part table in the current part WB
Dim PartAry() As String ' the array of parts from the main consolidated table
Dim PcArray() As String ' the array of parts from the main PARTS list
Dim rngHeader As Range ' the header from the main consolidated table
Dim sPart As String ' the current part
Dim sPrevPart As String ' test if a new part vs prev part
Dim sWorkbook As String ' the temporary master parts list workbook
Dim vHdr ' the array of the header from the main consolidated table to transfer to tabs
Dim vINI ' the INI info from the temp master workbook
'
' Collect Data from Main Parts List and Consolidated List
gsErrMsg = "DoFabReports Parsing Consolidated Main Data"
Call UpdateProgress(95, "Adding FabSheet Workbooks...")
sWorkbook = ActiveWorkbook.Name
Sheets("PARTS").Select
lNumPcRows = Cells(1, 1).CurrentRegion.Rows.Count
lNumPcCols = Cells(1, 1).CurrentRegion.Columns.Count
ReDim PcArray(lNumPcRows, lNumPcCols) As String
For Y = 1 To lNumPcRows
For X = 1 To lNumPcCols
PcArray(Y, X) = Cells(Y, X).Value
Next 'X
Next 'Y
vINI = Sheets("-INI-").Range("A:B")
Sheets("CONSOLIDATED").Select
Set rngHeader = Range(Cells(1, 1), Cells(5, 11))
vHdr = rngHeader
lNumRows = Cells(5, 1).CurrentRegion.Rows.Count - 1
lNumCols = Cells(5, 1).CurrentRegion.Columns.Count
ReDim PartAry(lNumRows, lNumCols) As String
For Y = 1 To lNumRows
For X = 1 To lNumCols
PartAry(Y, X) = Cells(5 + Y, X).Value
Next
Next
gsErrMsg = "DoFabReports Create new Workbook and list parts"
For Y = 1 To lNumRows
sPart = PartAry(Y, 1)
If sPart <> sPrevPart Then ' create new workbook and list parts
'first format previous tab and insert totals
If Y > 1 Then
GoSub FormatTab
lRow = lRow + 2
Cells(lRow, 4).Value = lAccumQty
Cells(lRow, 5).Value = dAccumFeet
Cells(lRow, 6).Value = dAccumWt
Columns("B:Z").Columns.AutoFit
Sheets("PARTS").Select
End If
lRow = 6: lPcRow = 1
lAccumQty = 0: dAccumFeet = 0: dAccumWt = 0
gsErrMsg = "Consolidating Main Data. Creating New Workbook " & sPart
Workbooks.Add
Sheets.Add.Name = "-INI-"
Range("A:B") = vINI
Sheets("-INI-").Move before:=Sheets(1)
Sheets("-INI-").Visible = xlSheetHidden
Sheets.Add.Name = "PARTS"
Rows("1:1").Font.Bold = True
Range("A:A").NumberFormat = "@"
Range("E:F").NumberFormat = "@"
For J = 1 To lNumPcCols
Cells(lPcRow, J).Value = PcArray(1, J) ' Dim (1,#) holds Header Titles
Next 'J
lPcRow = 2
For I = 1 To lNumPcRows
If sPart = PcArray(I, 1) Then
For J = 1 To lNumPcCols
Cells(lPcRow, J).Value = PcArray(I, J)
Next 'J
lPcRow = lPcRow + 1
End If
Next 'I
Range("C:C").NumberFormat = "# ??/??"
Columns("A:AZ").HorizontalAlignment = xlCenter
Columns("A:AZ").Columns.AutoFit
Sheets.Add.Name = "CONSOLIDATED"
Sheets("CONSOLIDATED").Move After:=Sheets("PARTS")
Sheets("CONSOLIDATED").Tab.ColorIndex = 1
Sheets("CONSOLIDATED").PageSetup.FitToPagesWide = 1
Sheets("CONSOLIDATED").PageSetup.FitToPagesTall = False
Sheets("CONSOLIDATED").Range(Cells(1, 1), Cells(5, 11)) = vHdr
Sheets("CONSOLIDATED").Range(Cells(1, 1), Cells(5, 11)).Font.Bold = True
For Z = 1 To UBound(DiesInfo())
If PartAry(Y, 1) = DiesInfo(Z).sPart Then
Cells(3, 1).Value = DiesInfo(Z).sDescription & " WT/FT=" & DiesInfo(Z).fPartWeight
Exit For
End If
Next 'Z
For X = 1 To lNumCols
Cells(lRow, X).Value = PartAry(Y, X)
If X = 4 Then lAccumQty = lAccumQty + Val(PartAry(Y, X))
If X = 5 Then dAccumFeet = dAccumFeet + Val(PartAry(Y, X))
If X = 6 Then dAccumWt = dAccumWt + Val(PartAry(Y, X))
Next 'x
sPrevPart = sPart
Else ' same part so list in current workbook
lRow = lRow + 1
For X = 1 To lNumCols
Cells(lRow, X).Value = PartAry(Y, X)
If X = 4 Then lAccumQty = lAccumQty + Val(PartAry(Y, X))
If X = 5 Then dAccumFeet = dAccumFeet + Val(PartAry(Y, X))
If X = 6 Then dAccumWt = dAccumWt + Val(PartAry(Y, X))
Next 'x
End If
Next 'Y
'format LAST tab
GoSub FormatTab
'add totals to LAST tab
lRow = lRow + 2
Cells(lRow, 4).Value = lAccumQty
Cells(lRow, 5).Value = dAccumFeet
Cells(lRow, 6).Value = dAccumWt
Columns("B:Z").Columns.AutoFit
gsErrMsg = "Finishing Fab Sheets"
Sheets("PARTS").Select
GoTo Xit
FormatTab:
Columns("A:A").ColumnWidth = 11.5
Columns("B:M").Columns.AutoFit
Columns("A:G").HorizontalAlignment = xlCenter
Range("A1:F5").Font.Bold = True
Range("A1:F5").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("B:B").NumberFormat = "# ??/??"
Range("D:D").NumberFormat = "0"
Range("E:E").NumberFormat = "0.00"
Range("E:E").HorizontalAlignment = xlRight
Range("F:F").NumberFormat = "0.0"
Columns("E:F").Style = "Comma"
Range("F:F").HorizontalAlignment = xlRight
Range("A1").HorizontalAlignment = xlLeft
Range("A2").HorizontalAlignment = xlLeft
Range("A3").HorizontalAlignment = xlLeft
Range("A1").Select
Return
Xit:
Unload frmProgress
DoEvents
Set rngHeader = Nothing
Application.DisplayAlerts = False
Workbooks(sWorkbook).Close ' close the temp master parts list
Application.Windows.Arrange xlArrangeStyleCascade
End Sub
'===============================================================================
'###############################################################################

 

[Norie]

Which line of code causes the error?

 

[cjcaldwell427]

Hi sadly I don't know. Sorry I don't know how to use the debug. Or how to determine which line it is. Need help with that also.

 

[Norie]

When you get the error you should have the option to Debug and the offending line of code should be highlighted.

Is that not happening?

 

[cjcaldwell427]

No it is not offering to debug. The author has code to display errors and to see the author for help and that is no longer an option.
I'll go to youtube to learn how to use the debug in the VBA editor and hopefully be able determine the hang up.

 

[Norie]

Try commnenting out all the lines of code starting On Error...

 

[cjcaldwell427]

Thanks Norie for the suggestions. I used "run to cursor" and found the error. The problem wasn't in the VBA code. The code opens a new workbook for the report and the code is looking for sheet1 and sheet2. The number of sheets in a new workbook was set on "one". I changed the default to "three" and the my problem was solved.

Thanks again,
CJ