VBA Code De-bugging in 2010 excel

[AllCom]

Looking for some help in debugging some old VBA/Macro code to work in the newer version of MS Excel 2010. The macro in question is the "Material Rollup" function. The purpose of the macro is after selecting a contiguous range of cells in a given column. Then macro will copy the information corresponding information range (B?:H?) To a new sheet or existing sheet, sort the information according to the values in the "Part #" column (D) . Up to this point the macro works as intended. But it errors out and when it tries to combine items with similar "part #" and delete the duplicate entries. Any help or assistance you can send my way would be greatly appreciated. The believe the errors/bug starts on the following line "Rollup, Like Part Numbers, Combine Quantities and Delete Rows".
Below is VBA code that has become the bane of my existence.




'************************** Material Rollup by Part Number *****************************
Function Material_Rollup()

MyfirstValue = 0
MyLastValue = 0
Cnt = 0
TopRow = 0
BottomRow = 0
CntDelRows = 0
NewLastRow = 0
Quantity = 0
loopCnt = 0
Dim MyBom As String
Dim MyRollup As String
Dim NextRow As String

MyBom = ActiveSheet.Name

If Val(Range("A2")) > 0 Or Val(Range("I1")) > 0 Then
MsgBox MyBom & " is not a BOM72 Work sheet or Material Rollup Sheet, Rollup Canceled."
Call GotoSheet
GoTo Cancel
End If

ReturnRows (Selection.Address)
MyfirstValue = My_First_Row
MyLastValue = My_Last_Row

If MyfirstValue = MyLastValue Then
Call BOM72ERR(3, "")
GoTo Cancel
End If

RetrySheet:
'Provide List of existing Sheets and input box for new Sheet Name
ListSheets (2)

If Pick_Sheet = "Pick_Sheet_Cancel" Then
Sheets(MyBom).Select
GoTo Cancel
Else
MyRollup = Pick_Sheet
End If

'See if Rollup sheet name exist or is new
For Each sh In ActiveWorkbook.Sheets

If UCase(sh.Name) = UCase(MyRollup) Then
DoesSheetExist = 1
Exit For
Else
DoesSheetExist = 0
End If
Next
'If Sheet exist make sure its a Material Rollup Sheet
If DoesSheetExist = 1 Then
If Worksheets(MyRollup).Range("E1").Value <= 0 Then
MsgBox MyRollup & " is not a Material Rollup Sheet."
GoTo RetrySheet
End If
End If

'If sheet doesn't exist, build and format
If DoesSheetExist = 0 Then

Sheets.Add
ActiveSheet.Name = MyRollup
ActiveWindow.DisplayGridlines = False
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

Worksheets("Data").Range("A4:W6").Copy (Worksheets(MyRollup).Range("A1"))

Range("a4").Select
ActiveWindow.FreezePanes = True

Range("A5").Select

TopRow = 4
Range("E1") = TopRow
End If

Worksheets(MyRollup).Select
TopRow = (Range("E1") + 1)
BottomRow = ((Val(MyLastValue) - Val(MyfirstValue)) + 1) + Range("E1").Value
Cnt = TopRow

Worksheets(MyBom).Range("B" + MyfirstValue + ":H" + MyLastValue).Copy (Worksheets(MyRollup).Range("B" & TopRow))

'Delete Rows that are not Material Items (Look for Text in Mfg Column)
For Each C In Worksheets(MyRollup).Range("C" & TopRow & ":C" & BottomRow)

If C.Value = "" Then
Rows((Cnt - CntDelRows)).Select
Selection.Delete Shift:=xlUp
CntDelRows = CntDelRows + 1

End If

Cnt = Cnt + 1
Next C


'Delete Rows with the Unit Price column colored Gray (Don't Rollup)
NewLastRow = (Cnt - (CntDelRows + 1))
Cnt = TopRow
CntDelRows = 0
For Each C2 In Worksheets(MyRollup).Range("G" & TopRow & ":G" & NewLastRow)

If C2.Interior.ColorIndex = 40 Then
Rows((Cnt - CntDelRows)).Select
Selection.Delete Shift:=xlUp
CntDelRows = CntDelRows + 1

End If

Cnt = Cnt + 1

Next C2


NewLastRow = (Cnt - (CntDelRows + 1))


'Sort Rollup by Part Number
Range("A" & TopRow & ":S" & NewLastRow).Select
Selection.Sort Key1:=Range("D" & TopRow), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Range("B" & TopRow).Select

Cells.Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
End With
Range("A1").Select

Cnt = TopRow
cnt2 = (Cnt + 1)
CntDelRows = 0
loopCnt = 0


'Rollup, Like Part Numbers, Combine Quantities and Delete Rows
For Each c1 In Worksheets(MyRollup).Range("D" & TopRow + ":D" & NewLastRow)

NextRow = Range("D" & cnt2)

If UCase(c1.Value) = UCase(NextRow) Then
Quantity = Range("E" & Cnt) + Range("E" & cnt2)
Range("E" & cnt2) = Quantity
Rows(Cnt).Select
Selection.Delete Shift:=xlUp
CntDelRows = CntDelRows + 1
Cnt = Cnt - 1
cnt2 = cnt2 - 1
Quantity = 0
End If

Cnt = (Cnt + 1)
cnt2 = (cnt2 + 1)

Next c1
NewLastRow = NewLastRow - CntDelRows

'Sort Rollup by Manufacturer then Part Number
Range("A" & TopRow & ":S" & NewLastRow).Select
Selection.Sort Key1:=Range("C" & TopRow), Order1:=xlAscending, Key2:=Range _
("D" & TopRow), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom

Range("B" + TopRow).Select
Worksheets("Data").Range("G8:W8").Copy Worksheets(MyRollup).Range("G" & TopRow & ":G" & NewLastRow)
Sheets(MyRollup).Select

Columns("K:S").Select
Selection.ColumnWidth = 6
Columns("A").Select
Selection.ColumnWidth = 3
Columns("B").Select
Selection.ColumnWidth = 20
Columns("C:D").Select
Selection.ColumnWidth = 12
Columns("E:F").Select
Selection.ColumnWidth = 6
Columns("H").Select
Selection.ColumnWidth = 3

Range("K5").Select

With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Range("E1") = NewLastRow
Range("A" & TopRow) = "WorkSheet: " & MyBom & " Rows: " & MyfirstValue & " to " & MyLastValue
Range("A" & TopRow).Font.ColorIndex = 22
If TopRow > 5 Then
Range("B1") = "Multi-Rollup Sheet"
Else
Range("B1") = "Single-Rollup Sheet"
End If
Range("B" + TopRow).Select
'Don't forget to value quantity column
Cancel:
End Function


Thank you for any help you can offer.

[Bob Phillips]

Only looked at the code, but are you sure it is working on the correct worksheet. Your ranges are not qualified, so I woulod always suspect that.

When you delete row, you should work bottom up, otherwise the pointers get out of step.

Selecting is not necessary. Instead of


Rows((Cnt - CntDelRows)).Select
Selection.Delete Shift:=xlUp


you should use


Rows(Cnt - CntDelRows).Delete Shift:=xlUp


(and qualify it of course)

and instaed of


Columns("K:S").Select
Selection.ColumnWidth = 6

use


Columns("K:S").ColumnWidth = 6

[snb]

1. you shouldn't use a function to do this, but a macro (Sub)
2. debugging without a workbook at our disposal is overasking: please post a sample workbook
3. there's no difference to the VBA you use in Excel 2010 or earlier; so that's not a problem

[AllCom]

1. you shouldn't use a function to do this, but a macro (Sub)
2. debugging without a workbook at our disposal is overasking: please post a sample workbook
3. there's no difference to the VBA you use in Excel 2010 or earlier; so that's not a problem


11663

Attached it the work book in question. From my understanding one should be able to select items such as (B6:B11) on the green tabs like "Alpha", Right click-->BOM-72-B-->Material Rollup. to run the Macro, if you select test as the "test" as target destination for the roll.

Once again thank you all for you help in advance

[AllCom]

thank for your help, to be perfectly honest a have little to no experience in generating or proofing any kind of programing language. I can make the changes you suggest as for inserting qualifying statements I would not have clue were to start

[Bob Phillips]

I have taken an, albeit rudimentary, look at your workbook, and it seems quite an extensive task to help you. I followed the suggested test and I got no error (I have no idea if it did what it should, but no error). If this is an important workbook in your company, I would suggest you commission an Excel/VBA professional to overhaul it.

[AllCom]

I have taken an, albeit rudimentary, look at your workbook, and it seems quite an extensive task to help you. I followed the suggested test and I got no error (I have no idea if it did what it should, but no error). If this is an important workbook in your company, I would suggest you commission an Excel/VBA professional to overhaul it.


In theory it should have rolled up/consolidated 6 line items to 3 line items with updated quantities. Part A having a total of 2, part B= 6, and part c = 4

[Kenneth Hobs]

It did not remove duplicates but neither did it error for me. I ran it once and set the sheet as new, ken. I ran it again and selected sheet ken, and it appended the data. Getting your structure laid out properly is important I suspect so that is why I made it create the new sheet, ken, first.

Maybe detail what you are doing so that we can try to duplicate the error. As for removing duplicates, I don't see that coded in Material_Rollup.

The code could be improved and made shorter and more lean by removing some of the selects that seem unneeded. That is another matter for another thread though.