Нужна помощь в отладке старого кода VBA/Macro для работы в более новой версии MS Excel 2010. Рассматриваемый макрос - это функция "Свертывание материала".

Цель макроса - после выбора непрерывного диапазона ячеек в данном столбце. Тогда макрос скопирует информацию соответствующего информационного диапазона (B?:H?) Сортируйте информацию по новому или существующему листу в соответствии со значениями в столбце «Номер детали» (D).

До этого момента макрос работает как задумано. Но он выдает ошибку, и когда он пытается объединить элементы с аналогичным «part #» и удалить дублирующиеся записи. Любая помощь или помощь, которую вы можете отправить мне, будет принята с благодарностью.

Предполагается, что ошибки / ошибки начинаются со следующей строки "Свернуть, Как номера деталей, Объединить количества и Удалить строки".

Ниже приведен код VBA, ставший проклятием моего существования.

'**************************  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

Спасибо за любую помощь, которую вы можете предложить.

|источник

2 ответа2

2

Это «+» неправильно.

Вы объединяете строки с помощью & и добавляете числа с помощью + .

Притворимся TopRow = 1, а NewLastRow = 5:

Вы пытаетесь добавить "D1" к «:D5», и, поскольку вы не можете выполнять математические добавления для строк, вы получаете ошибку несоответствия типов при попытке.

Кроме того, проблемы выходных значений без синтаксических ошибок - это логические проблемы, для решения которых нам понадобится другая конкретная информация. Таким образом, эти вопросы, вероятно, лучше всего рассматривать как новые вопросы (с предоставлением соответствующей информации), чтобы мы могли решать проблемы, с которыми вы сталкиваетесь по одному, после того, как вы выполнили свою часть исследования их. :)

|источник
0
 
1. I noticed a mixture of &'s and +'s.
   1a. I fixed them.

2. I think you need to cast your integers to strings (TopRow, NewLastRow, others). 
   2a. I cast them for you.

Я вырезал ваш код точно.

Я добавил несколько комментариев, которые вы увидите зеленым цветом, как только вы обрежете это и вставите его.

Я добавил приведение к вашим целым числам в полях Range.

Если ваш код правильный, теперь он будет работать. Если это все-таки Err, то вы должны взглянуть на некоторую логику. Используйте некоторую отладку для сообщения себя, например, MsgBox "пробуя код var:" & myvar


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:

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

    'Does Range("E1") return an address or integer?
    Dim myMessage = "Range("E1") return an address or integer? TopRow = "     

    Range("E1") = TopRow

    MsgBox myMessage & TopRow

End If

Worksheets(MyRollup).Select

'
'TopRow = Address + 1? Does Range("E1") return an integer?

TopRow = (Range("E1") + 1)

MsgBox myMessage & TopRow

'Is Val(MyFirstValue), Val necessary, or help, or hinder?


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

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

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

       If C.Value = "" Then
           'Added Cast to summation
           Rows(CStr((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

'Casting
For Each C2 In Worksheets(MyRollup).Range("G" & CStr(TopRow) & ":G" & CStr(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
'Casting
Range("A" & CStr(TopRow) & ":S" & CStr(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

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

        NextRow = Range("D" & cnt2)

       'Casting
       If UCase(c1.Value) = UCase(NextRow) Then
          Quantity = Range("E" & CStr(Cnt)) & Range("E" & CStr(cnt2))
          Range("E" & CStr(cnt2)) = Quantity

          '?Cast here? CStr(Cnt)?

          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

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

    'Casting
    Range("B" + CStr(TopRow)).Select
    Worksheets("Data").Range("G8:W8").Copy Worksheets(MyRollup).Range("G" & CStr(TopRow) & ":G" & CStr(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

    'Casting
    Range("E1") = NewLastRow          '? CStr(NewLastRow) ? Might need here!
    Range("A" & TopRow) = "WorkSheet: " & MyBom & "    Rows: " & CStr(MyfirstValue) & " to " & CStr(MyLastValue)
    Range("A" & CStr(TopRow)).Font.ColorIndex = 22
    If TopRow > 5 Then
        Range("B1") = "Multi-Rollup Sheet"
        Else
        Range("B1") = "Single-Rollup Sheet"
    End If
    Range("B" + CStr(TopRow)).Select
    'Don't forget to value quantity column
Cancel:
End Function
|источник

Всё ещё ищете ответ? Посмотрите другие вопросы с метками .