Question

我正在使用计算机在Excel中使用VBA自动化报价它包括查找重复项，以便将它们相加。

例如：

我有以下信息：

Click here表示Excel文件

A2：C4的范围表示有28个螺栓，每个螺栓和螺栓有1个螺母。每个螺栓有1个垫圈。

A5：C7是另一组28个螺栓，每个螺栓和螺栓有1个螺母。每个螺栓有1个垫圈。

A11：C13是另一组，但区别在于这个是2个坚果＆amp;每个螺栓2个垫圈。

所以这不是总和

这将是结果：

我有以下代码，它只查看所有单元格，我无法找到一种方法使其在组或范围内查看。

Sub Macro1()

Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

With wSrc
    LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
    Set rng = .Range("B1:B" & LastRow)
    LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
    rng.AdvancedFilter Action:=xlFilterCopy, copytoRange:=.Cells(1, LastColumn), unique:=True
    Z = .Cells(.Rows.Count, LastColumn).End(xlUp).Row
    LastColumn = LastColumn + 1
    .Cells(1, LastColumn).Value = "Total"
    .Range(.Cells(2, LastColumn), .Cells(Z, LastColumn)).Formula = _
        "=SUMIF(" & rng.Address & "," & .Cells(2, LastColumn - 1).Address(False, False) & "," & rng.Offset(, 1).Address & ")"
End With

With Application
    .ScreenUpdating = Truek
    .Calculation = xlCalculationAutomatic
End With

End Sub

单击下面的Excel文件

Answer 1

采取不同的方法。

利用结构;三行定义它
将结果放在不同的标签

此输入......

生成此输出......

使用此代码...

Option Explicit

Sub Macro1()

Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long

' turn off updating for speed
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)

With tmpSrc

    .Name = "Hoja2"
    Set outRng = .UsedRange
    LastRow = .UsedRange.Rows.Count
    LastColumn = .UsedRange.Columns.Count

End With

' loop down through the range
For iLoop = 2 To LastRow
    If outRng.Cells(iLoop, 1) <> "" Then

        QSum = outRng.Cells(iLoop, 1).Value
        For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match

        ' matches are defined by all three rows in column B
            If outRng.Cells(jLoop, 1) <> "" And _
                outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
                outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
                outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then

                QSum = QSum + outRng.Cells(jLoop, 1).Value
                outRng.Rows(jLoop + 2).Delete
                outRng.Rows(jLoop + 1).Delete
                outRng.Rows(jLoop).Delete
                LastRow = LastRow - 3

            End If
        Next jLoop

        outRng.Cells(iLoop, 1).Value = QSum

    End If
Next iLoop

For iLoop = 1 To 3
    outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

编辑：

螺栓，螺母和垫圈的总重量
检查螺母和垫圈是否按相反顺序出现
n.b。我正在使用.UsedRange来查找最后一行和最后一列。其他方法也可以。

Option Explicit

Sub Macro1()

Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
Dim WSum1 As Double, WSum2 As Double, WSum3 As Double

' turn off updating for speed
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)

With tmpSrc
    .Name = "Hoja2"
    Set outRng = .UsedRange
    LastRow = .UsedRange.Rows.Count
    LastColumn = .UsedRange.Columns.Count
End With

' loop down through the range
For iLoop = 2 To LastRow
    If outRng.Cells(iLoop, 1) <> "" Then


    QSum = outRng.Cells(iLoop, 1).Value
    WSum1 = outRng.Cells(iLoop, 3).Value
    WSum2 = outRng.Cells(iLoop + 1, 3).Value
    WSum3 = outRng.Cells(iLoop + 2, 3).Value
    For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
    ' matches are defined by all three rows in column B
        If outRng.Cells(jLoop, 1) <> "" And _
        outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
        outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
        outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then

            QSum = QSum + outRng.Cells(jLoop, 1).Value
            WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
            WSum2 = WSum2 + outRng.Cells(jLoop + 1, 3).Value
            WSum3 = WSum3 + outRng.Cells(jLoop + 2, 3).Value
            outRng.Rows(jLoop + 2).Delete
            outRng.Rows(jLoop + 1).Delete
            outRng.Rows(jLoop).Delete
            LastRow = LastRow - 3
        Else ' check if bolts and washers are in reverse order
            If outRng.Cells(jLoop, 1) <> "" And _
                outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
                outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 2, 2) And _
                outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 1, 2) Then

                QSum = QSum + outRng.Cells(jLoop, 1).Value
                WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
                WSum2 = WSum2 + outRng.Cells(jLoop + 2, 3).Value
                WSum3 = WSum3 + outRng.Cells(jLoop + 1, 3).Value
                outRng.Rows(jLoop + 2).Delete
                outRng.Rows(jLoop + 1).Delete
                outRng.Rows(jLoop).Delete
                LastRow = LastRow - 3
            End If

        End If
    Next jLoop

    outRng.Cells(iLoop, 1).Value = QSum
    outRng.Cells(iLoop, 3).Value = WSum1
    outRng.Cells(iLoop + 1, 3).Value = WSum2
    outRng.Cells(iLoop + 2, 3).Value = WSum3

End If
Next iLoop

For iLoop = 1 To 3
    outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Answer 2

这是一种利用硬件和硬件组的用户定义对象的方法。

我们可以用更少的循环创建更紧凑的代码，但是，除非存在显着的速度问题，否则这可能更具可读性，并且可以更容易地适应未来的需求。

我们创建了两个类模块（并确保按照代码中的指示重命名它们）。一个类模块用于硬件项，第二个模块用于不同的组。

硬件项属性是描述，每个项目的权重和项目数。

硬件组属性是硬件项目的集合，以及该组中的项目数量。

然后，我们将硬件组合并为一组独特的硬件组。

编写代码时，您可以通过其他方式组合生成其他类型的报告。

结果：

课程模块1

'**Rename:  cHardware**

Option Explicit
Private pDescription As String
Private pWt As Double
Private pItemCount As Long

Public Property Get Description() As String
    Description = pDescription
End Property
Public Property Let Description(Value As String)
    pDescription = Value
End Property

Public Property Get Wt() As Double
    Wt = pWt
End Property
Public Property Let Wt(Value As Double)
    pWt = Value
End Property

Public Property Get ItemCount() As Long
    ItemCount = pItemCount
End Property
Public Property Let ItemCount(Value As Long)
    pItemCount = Value
End Property

课程模块2

'**Rename: cHardwareGrp**

Option Explicit
Private pHW As cHardWare
Private pHWs As Collection
Private pQty As Long

Private Sub Class_Initialize()
    Set pHWs = New Collection
End Sub

Public Property Get HW() As cHardWare
    Set HW = pHW
End Property
Public Property Let HW(Value As cHardWare)
    Set pHW = Value
End Property

Public Property Get HWs() As Collection
    Set HWs = pHWs
End Property
Public Function AddHW(Value As cHardWare)
Dim I As Long, J As Long
    If pHWs.Count = 0 Then
        pHWs.Add Value
    Else 'Insert in sorted order
        For J = pHWs.Count To 1 Step -1
            If pHWs(J).Description <= Value.Description Then Exit For
        Next J
        If J = 0 Then
            pHWs.Add Value, before:=1
        Else
            pHWs.Add Value, after:=J
        End If
    End If
End Function    
Public Property Get Qty() As Long
    Qty = pQty
End Property
Public Property Let Qty(Value As Long)
    pQty = Value
End Property

常规模块

Option Explicit
Sub SummarizeHW()
    Dim wsRes As Worksheet, wsSrc As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim cHW As cHardWare, colHW As Collection
    Dim cHWG As cHardwareGrp, colHWG As Collection
    Dim colUniqueHWG As Collection
    Dim I As Long, J As Long, K As Long
    Dim lQTY As Long
    Dim S As String
    Dim V As Variant

    Dim RE As Object, MC As Object

'Set Source and Results Worksheets and Ranges
Set wsSrc = Worksheets("Hoja1")
Set wsRes = Worksheets("Hoja2")
    Set rRes = wsRes.Cells(1, 1)

'Get Source Data
With wsSrc
    vSrc = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)) _
        .Offset(columnoffset:=-1).Resize(columnsize:=3)
End With

'Set up regex to extract number of HW items in description
Set RE = CreateObject("vbscript.regexp")
With RE
    .Global = False
    .Pattern = "^\((\d+)\)\s*"
    .MultiLine = True
End With

'Collect unique list of hardware items
' compute the weight of each single item
Set colHW = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1) 'assumes header row
    If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
    Set cHW = New cHardWare
    With cHW
        S = vSrc(I, 2)
        If RE.test(S) = True Then
            Set MC = RE.Execute(S)
            .ItemCount = CLng(MC(0).submatches(0))
        Else
            .ItemCount = 1
        End If
            .Wt = vSrc(I, 3) / lQTY / .ItemCount
        .Description = S
        colHW.Add cHW, .Description
    End With
Next I
On Error GoTo 0

'Collect the Hardware Groups
'HW group starts if there is a "Qty" in column 1
Set colHWG = New Collection
For I = 2 To UBound(vSrc, 1)
    If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
    Set cHWG = New cHardwareGrp

    Do
    With cHWG
        .HW = colHW(vSrc(I, 2))
        .AddHW .HW
        .Qty = lQTY
    End With
    I = I + 1
    If I > UBound(vSrc, 1) Then Exit Do
    Loop Until vSrc(I, 1) <> ""

    colHWG.Add cHWG
    I = I - 1
Next I

'Collect the unique hardware groups
' A group is defined by ALL of the hardware components being identical
' in both type and quantity.  Therefore, we can concatenate them as a key

Set colUniqueHWG = New Collection
On Error Resume Next
For I = 1 To colHWG.Count
    With colHWG(I)
        ReDim V(1 To .HWs.Count)
        For J = 1 To UBound(V)
            V(J) = .HWs(J).Description
        Next J
        S = Join(V, "|")
        colUniqueHWG.Add colHWG(I), S
        Select Case Err.Number
            Case 457 'a duplicate so add the QTY
                colUniqueHWG(S).Qty = colUniqueHWG(S).Qty + .Qty
                Err.Clear
            Case Is <> 0 'error stop
                Debug.Print Err.Number, Err.Description
        End Select
    End With
Next I
On Error GoTo 0

'Final Report
'# of columns = 3
'# of rows = sum of the number of HW items in each group + 1 for the header
J = 0
For I = 1 To colUniqueHWG.Count
    J = J + colUniqueHWG(I).HWs.Count
Next I

ReDim vRes(0 To J, 1 To 3)
'Column headers
vRes(0, 1) = "Qty"
vRes(0, 2) = "Hardware Description"
vRes(0, 3) = "Weight"

'populate the results array'
K = 1
For I = 1 To colUniqueHWG.Count
    With colUniqueHWG(I)
        For J = 1 To .HWs.Count
            If J = 1 Then vRes(K, 1) = .Qty
            vRes(K, 2) = .HWs(J).Description
            vRes(K, 3) = .Qty * .HWs(J).Wt * .HWs(J).ItemCount
            K = K + 1
        Next J
    End With
Next I

'Write the results on a new sheet
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .ColumnWidth = 255
    With Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With
End Sub

嗯。我从你的评论中看到，硬件可能并不总是处于相同的顺序。我将为我们的小组生成添加一个排序例程，这将是无关紧要的。

编辑：修改AddHW功能以按排序顺序插入HW项目。由于只应该有几个项目，因此这种插入排序应该足够了。

比较范围，看它们是否相等

2 个答案:

课程模块1

课程模块2

常规模块