Ive written an app that loops thru AutoCad drawings, a few spreadsheets, a database or two, and some in-house proprietary file types Ive reverse engineered the file format of.
It collects the information, then fires up a new spreadsheet to write the data, text format, into 9 columns wide, times (however-many-records there are) rows. It also writes a little to a second worksheet, in the same format.
It doesnt always tank, but when it does, it always does it in the same spot - on the sorting of the data. It doesnt always tank, even when I run the SAME DATA, and the exact same data is written to the spreadsheet!
And sometimes it tanks with a different error message - while the error message is usually "Method 'Range' of Object '_Global' failed", it sometimes tanks with "The remote server machine does not exist". On the same line of code, as always, and running the exact same data, as always.
It seems to make no difference how much data is generated, I can rerun the code over and over on the same data, and sometimes it tanks on a little data, and sometimes it tanks on a lot of data - and ive been testing it over and over with the SAME DATA.
Two things are consistent, though - it never tanks when run under Office 2007 (the Excel macro was originally recorded under 2003), and, if I set up error traps, either BOTH data sorts on both sheets generate errors, or neither does. and always the the same place(s): the sorts - see the lines of code @ "With MatlSheet.Range(TotalRange$)"
" .Sort Key1:=Range("E2"), Order1:=xlAscending," ... etc etc
Ive sprinkled the code with doevents. Ive made sure to clean up my objects (to NOTHING) when leaving each subroutine. I tried exporting all the modules, and re-importing into a fresh office 2003 vba format, and reload the references using the older versions. Im at wits end.
What Id really like to have, is a robust sorting algorithm to sort multiple columns of data, and then I can do all this crap myself.
Here is the entire, ugly sub. the xl object is declared at the module level, and is removed by the calling subroutine. The workbook object created by the routine is left open on purpose, for the user to see. (Excel is fired up invisibly at the start of the routine, and made visible once all the writing is done)
'---------- snip ----------------------------------
[VBA] Sub GenerateReport()
Dim reportBook As Workbook
Set reportBook = xl.Workbooks.Add
Dim MatlSheet As Worksheet
Dim HwSheet As Worksheet
Dim I%, J%, tmp$
Dim hasBreak%, SubFactor&, NumParts&, K%, TotalRange$
Dim ERange$, CRange$, BRange$, MyRange$, EdgeRange$
Dim tmpRange As Range
frmProgress.ForceMax ("Generating Report")
xl.ScreenUpdating = False
Set MatlSheet = reportBook.Sheets("Sheet3")
MatlSheet.Delete
Set HwSheet = reportBook.Sheets("Sheet2")
HwSheet.Name = "Hardware"
Set MatlSheet = reportBook.Sheets("Sheet1")
MatlSheet.Name = "Materials"
MatlSheet.Activate
MatlSheet.Range("A1").Value = "Product #"
MatlSheet.Range("B1").Value = "Product Name"
MatlSheet.Range("C1").Value = "Part Name"
MatlSheet.Range("D1").Value = "Qty"
MatlSheet.Range("E1").Value = "Material"
MatlSheet.Range("F1").Value = "EB-01"
MatlSheet.Range("G1").Value = "EB-02"
MatlSheet.Range("H1").Value = "EB-03"
MatlSheet.Range("I1").Value = "EB-04"
HwSheet.Range("A1").Value = "Product #"
HwSheet.Range("B1").Value = "Product Name"
HwSheet.Range("C1").Value = "Part Owner"
HwSheet.Range("D1").Value = "Part Name"
HwSheet.Range("E1").Value = "Qty"
Dim CurrentMatlRow As Long: CurrentMatlRow = 1
Dim RowStr As String
Dim CurrentHWRow As Long: CurrentHWRow = 1
' completed here: now dump the data
For I% = 0 To ProductCount
If ProductInfo(I%).SelectedForProcessing = True Then
'------------------------------------------------------------------------------------------
If ProductInfo(I%).PartCount > -1 Then
MatlSheet.Activate
For J% = 0 To ProductInfo(I%).PartCount
CurrentMatlRow = CurrentMatlRow + 1
RowStr = LTrim$(Str$(CurrentMatlRow))
MatlSheet.Range("A" & RowStr).Value = ProductInfo(I%).ItemNumber
MatlSheet.Range("B" & RowStr).Value = ProductInfo(I%).ProductName
MatlSheet.Range("C" & RowStr).Value = ProductInfo(I%).PartInfo(J%).PartName
MatlSheet.Range("D" & RowStr).Value = ProductInfo(I%).PartInfo(J%).Qty
tmp$ = ProductInfo(I%).PartInfo(J%).Material
hasBreak% = InStr(1, tmp$, "(")
If hasBreak% > 1 Then tmp$ = Left$(tmp$, hasBreak% - 1)
MatlSheet.Range("E" & RowStr).Value = tmp$
MatlSheet.Range("F" & RowStr).Value = ProductInfo(I%).PartInfo(J%).EdgeBand1
MatlSheet.Range("G" & RowStr).Value = ProductInfo(I%).PartInfo(J%).EdgeBand2
MatlSheet.Range("H" & RowStr).Value = ProductInfo(I%).PartInfo(J%).Edgeband3
MatlSheet.Range("I" & RowStr).Value = ProductInfo(I%).PartInfo(J%).Edgeband4
Next J%
End If
If ProductInfo(I%).HardwareCount > -1 Then
HwSheet.Activate
For J% = 0 To ProductInfo(I%).HardwareCount
CurrentHWRow = CurrentHWRow + 1
RowStr = LTrim$(Str$(CurrentHWRow))
HwSheet.Range("A" & RowStr).Value = ProductInfo(I%).ItemNumber
HwSheet.Range("B" & RowStr).Value = ProductInfo(I%).ProductName
HwSheet.Range("c" & RowStr).Value = "[Base Product]"
HwSheet.Range("D" & RowStr).Value = ProductInfo(I%).HardwareInfo(J%).HwName
HwSheet.Range("E" & RowStr).Value = ProductInfo(I%).HardwareInfo(J%).Qty
Next J%
End If
If ProductInfo(I%).SubAssyCount > -1 Then
For J% = 0 To ProductInfo(I%).SubAssyCount
SubFactor& = ProductInfo(I%).SubAssyInfo(J%).Qty
' loop thru and print oput subassembly CutParts
NumParts& = ProductInfo(I%).SubAssyInfo(J%).PartCount
If NumParts& > -1 Then
MatlSheet.Activate
For K% = 0 To NumParts&
CurrentMatlRow = CurrentMatlRow + 1
RowStr = LTrim$(Str$(CurrentMatlRow))
MatlSheet.Range("A" & RowStr).Value = ProductInfo(I%).ItemNumber
MatlSheet.Range("B" & RowStr).Value = ProductInfo(I%).ProductName
MatlSheet.Range("C" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).PartInfo(K%).PartName
MatlSheet.Range("D" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).PartInfo(K%).Qty * SubFactor&
tmp$ = ProductInfo(I%).SubAssyInfo(J%).PartInfo(K%).Material
hasBreak% = InStr(1, tmp$, "(")
If hasBreak% > 1 Then tmp$ = Left$(tmp$, hasBreak% - 1)
MatlSheet.Range("E" & RowStr).Value = tmp$
MatlSheet.Range("F" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).PartInfo(K%).EdgeBand1
MatlSheet.Range("G" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).PartInfo(K%).EdgeBand2
MatlSheet.Range("H" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).PartInfo(K%).Edgeband3
MatlSheet.Range("I" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).PartInfo(K%).Edgeband4
Next K%
End If
' loop thru and print oput subassembly Hardware
NumParts& = ProductInfo(I%).SubAssyInfo(J%).HardwareCount
If NumParts& > -1 Then
HwSheet.Activate
For K% = 0 To NumParts&
CurrentHWRow = CurrentHWRow + 1
RowStr = LTrim$(Str$(CurrentHWRow))
HwSheet.Range("A" & RowStr).Value = ProductInfo(I%).ItemNumber
HwSheet.Range("B" & RowStr).Value = ProductInfo(I%).ProductName
HwSheet.Range("C" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).AssyName
HwSheet.Range("D" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).HardwareInfo(K%).HwName
HwSheet.Range("E" & RowStr).Value = ProductInfo(I%).SubAssyInfo(J%).HardwareInfo(K%).Qty * SubFactor&
Next K%
End If
Next J%
End If
'------------------------------------------------------------------------------------------
End If
Next I%
' --------------------now format report
MatlSheet.Columns("A:A").EntireColumn.AutoFit
MatlSheet.Columns("B:B").EntireColumn.AutoFit
MatlSheet.Columns("C:C").EntireColumn.AutoFit
MatlSheet.Columns("D").EntireColumn.AutoFit
MatlSheet.Columns("E:E").EntireColumn.AutoFit
MatlSheet.Columns("F:F").EntireColumn.AutoFit
MatlSheet.Columns("G:G").EntireColumn.AutoFit
MatlSheet.Columns("H:H").EntireColumn.AutoFit
MatlSheet.Columns("I:I").EntireColumn.AutoFit
HwSheet.Columns("A:A").EntireColumn.AutoFit
HwSheet.Columns("B:B").EntireColumn.AutoFit
HwSheet.Columns("C:C").EntireColumn.AutoFit
HwSheet.Columns("D
'
RowStr = LTrim$(Str$(CurrentMatlRow))
MatlSheet.Range("A" & RowStr).NumberFormat = "0.00"
TotalRange$ = "A2:I" & RowStr
ERange$ = "E2:E" & RowStr
CRange$ = "C2:C" & RowStr
BRange$ = "B2:B" & RowStr
MatlSheet.Activate
' ****** HERE COMES THE CHEESE, SPORTS FANS *****************************
' ****** IF IT'S GONNA TANK, IT TANKS HERE WITH THE ERROR TRAPS GONE*****
On Error Resume Next
Debug.Print TotalRange$
With MatlSheet.Range(TotalRange$)
.Sort Key1:=Range("E2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
End With
Err.Clear
On Error GoTo 0
' ***** END OF CHEESE CODE***** ITS SAFE TO COME OUT NOW *******
'--------------------------------- format the edgebanding
EdgeRange$ = "F2:I" & RowStr
MatlSheet.Range(EdgeRange$).Borders(xlDiagonalDown).LineStyle = xlNone
MatlSheet.Range(EdgeRange$).Borders(xlDiagonalUp).LineStyle = xlNone
With MatlSheet.Range(EdgeRange$).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With MatlSheet.Range(EdgeRange$).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With MatlSheet.Range(EdgeRange$).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With MatlSheet.Range(EdgeRange$).Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With MatlSheet.Range(EdgeRange$).Borders(xlInsideVertical)
.LineStyle = xlDash
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With MatlSheet.Range(EdgeRange$).Borders(xlInsideHorizontal)
.LineStyle = xlDash
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
' ----sort the hardware
RowStr = LTrim$(Str$(CurrentHWRow))
EdgeRange$ = "A2:E" & RowStr
HwSheet.Activate
' ****** HERE COMES THE CHEESE, SPORTS FANS *****************************
' ****** IF IT'S GONNA TANK, IT TANKS HERE WITH THE ERROR TRAPS GONE*****
On Error Resume Next
HwSheet.Range(EdgeRange$).Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
Debug.Print "Error hardware Sort = "; Err.Number
Err.Clear
On Error GoTo 0
' ***** END OF CHEESE CODE***** ITS SAFE TO COME OUT NOW *******
MatlSheet.Activate
'----------------------------------------------------------------------
'-------------------------------------------------------------------------
' ---------------- set Print area for material Sheet
RowStr = LTrim$(Str$(CurrentMatlRow))
''' Range("A1:I32").Select
MatlSheet.PageSetup.PrintArea = "$A$1:$I$" & RowStr
With MatlSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
MatlSheet.PageSetup.PrintArea = "$A$1:$I$" & RowStr
With MatlSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = xl.InchesToPoints(0.75)
.RightMargin = xl.InchesToPoints(0.75)
.TopMargin = xl.InchesToPoints(1)
.BottomMargin = xl.InchesToPoints(1)
.HeaderMargin = xl.InchesToPoints(0.5)
.FooterMargin = xl.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
xl.ScreenUpdating = True
xl.Visible = True
Set MatlSheet = Nothing
Set HwSheet = Nothing
xl.Visible = True
End Sub[/VBA]
Edited by Aussiebear: Using the VBA tag button makes the code supplied so much easier to read.
Reply With Quote
