查找匹配 VBA 的行号

Question

在一张表中，我有一个姓名列表，在另一列中有一个与之相关的金额。我需要在另一张纸的一列中写下这些名称而不重复。当名称重复时，我还需要汇总金额。 例如：

XXXX 20
YYYY 30
XXXX 10

我的结果应该是

XXXX 30
YYYY 30

我正在执行一个 for 循环来遍历名称，如果我没有在结果列中写下该名称，我会写下它。如果我已经写了，我将不得不留在同一行并计算金额的总和。 问题是我尝试使用 Range.Find，但即使名称已经写好，它也总是返回 Nothing。

代码如下：

Sub CommandButton1_Click()

Dim rif_reg As Integer
Dim rif_col As Integer
Dim riga_vuota As Integer
Dim rif_foglio As Integer
Dim rowNum As Range

For Each area In Worksheets("XXX").Range("C15:C26,C30:C41,C44:C55,C58:C69").Areas 'more than 1 selected area
    For Each cell In area 'loop through each cell in the selected range
        If IsEmpty(cell) = False Then
            If IsNumeric(cell) = False Then
                If Range("A61:A74").Find(What:=cell.Value2, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True) is Nothing Then 'search if the name has not being inserted yet
                    Cells(rif_rig + 61, rif_col + 1) = cell 'Nominativo
                    Cells(rif_rig + 61, rif_col + 7) = Worksheets("XXX").Cells(area.Cells(1).Row, rif_col + 1).Value2 'Ruolo
                    Cells(rif_rig + 61, rif_col + 11) = (Worksheets("XXX").Cells(cell.Row, rif_col + 5).Value2 * Worksheets("YYY").Cells(rif_foglio + 32, rif_col + 2)) 'Quota Lordo
                    rif_rig = rif_rig + 1
                Else
                    Set rowNum = Range("A61:A74").Find(What:=cell.Value2, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                    Cells(rowNum.Row, rif_col + 11) = (Cells(rowNum.Row, rif_col + 11) + Worksheets("XXX").Cells(cell.Row, rif_col + 5).Value2 * Worksheets("YYY").Cells(rif_foglio + 32, rif_col + 2)) 'Quota Lordo
                    If Cells(rowNum.Row, rif_col + 7) <> Worksheets("XXX").Cells(area.Cells(1).Row, rif_col + 1).Value2 Then
                        Cells(rowNum.Row, rif_col + 7) = Cells(rowNum.Row, rif_col + 8) & "," & Worksheets("XXX").Cells(area.Cells(1).Row, rif_col + 1).Value2 'Ruolo
                    Else
                        Cells(rowNum.Row, rif_col + 7) = Worksheets("XXX").Cells(area.Cells(1).Row, rif_col + 1).Value2 'Ruolo
                    End If
                End If
            Else
            End If
        Else
        End If
    Next
areaCount = areaCount + 1
Next

由于这不起作用，我尝试使用 Application.Match 但这并没有给我正确的行号

Sub CommandButton1_Click()

Dim rif_reg As Integer
Dim rif_col As Integer
Dim riga_vuota As Integer
Dim rif_foglio As Integer
Dim rowNum As Long

For Each area In Worksheets("XXX").Range("C15:C26,C30:C41,C44:C55,C58:C69").Areas 'more than 1 selected area
    For Each cell In area 'loop through each cell in the selected range
        If IsEmpty(cell) = False Then
            If IsNumeric(cell) = False Then
                If IsError(Application.Match(cell.Value2, Range("A61:A74"), 0)) Then 'search if the name has not being inserted yet
                    Cells(rif_rig + 61, rif_col + 1) = cell 'Nominativo
                    Cells(rif_rig + 61, rif_col + 7) = Worksheets("XXX").Cells(area.Cells(1).Row, rif_col + 1).Value2 'Ruolo
                    Cells(rif_rig + 61, rif_col + 11) = (Worksheets("XXX").Cells(cell.Row, rif_col + 5).Value2 * Worksheets("YYY").Cells(rif_foglio + 32, rif_col + 2)) 'Quota Lordo
                    rif_rig = rif_rig + 1
                Else
                    rowNum = Application.WorksheetFunction.Match(cell.Value2, Range("A61:A74"), 0)
                    Cells(rowNum, rif_col + 11) = (Cells(rowNum, rif_col + 11) + Worksheets("XXX").Cells(cell.Row, rif_col + 5).Value2 * Worksheets("YYY").Cells(rif_foglio + 32, rif_col + 2)) 'Quota Lordo
                    If Cells(rowNum, rif_col + 7) <> Worksheets("XXX").Cells(area.Cells(1).Row, rif_col + 1).Value2 Then
                        Cells(rowNum, rif_col + 7) = Cells(rowNum, rif_col + 8) & "," & Worksheets("XXX").Cells(area.Cells(1).Row, rif_col + 1).Value2 'Ruolo
                    Else
                        Cells(rowNum, rif_col + 7) = Worksheets("XXX").Cells(area.Cells(1).Row, rif_col + 1).Value2 'Ruolo
                    End If
                End If
            Else
            End If
        Else
        End If
    Next
areaCount = areaCount + 1
Next

谢谢， 卡洛塔。

附：我是 VBA 新手，所以我的代码可能非常混乱

Answer 1

您不必遍历范围内的所有区域（大约是For Each area In Worksheets("XXX")...）。只需遍历范围内的单元格，范围对象将负责将它们全部显示给您。

另外，不要将所有范围都写入宏。您每次都必须更改代码才能选择其他单元格。在运行宏之前选择所需的单元格并使用 Selection 对象会更容易（请不要担心这里有这么多文字 - 实际上，代码不到 30 行，其余的都是 cmets 给你）：

Sub SumsByNames()
Dim rSource As Range
Dim aCell As Range  ' Iterate by each cells in current Selection
Dim aData As Variant    ' Array for Names and ranges with this Name
Dim i As Long
    aData = Array() ' Empty array
    Set rSource = Application.Intersect(Selection, ActiveSheet.UsedRange)
    For Each aCell In rSource ' If cell is not empty then .text also not empty string
        If aCell.Text <> vbNullString Then
            If Not IsNumeric(aCell) Then
                Call addToData(aData, aCell.Text, aCell.Offset(0, 1))
            End If
        End If
    Next aCell
    Set aCell = Worksheets("Result").Range("A61")
    aCell.CurrentRegion.ClearContents
    For i = LBound(aData) To UBound(aData)
        aCell.Value = aData(i)(0)   ' Paste Name
        aCell.Offset(0, 1).Value = Application.WorksheetFunction.Sum(aData(i)(1))
        Set aCell = aCell.Offset(1, 0)
    Next i
End Sub

Sub addToData(ByRef aData As Variant, sName As String, rCell As Range)
Dim i As Long
    For i = LBound(aData) To UBound(aData)
        If aData(i)(0) = sName Then
            Set aData(i)(1) = Application.Union(aData(i)(1), rCell)
            Exit Sub
        End If
    Next i
    i = UBound(aData) + 1
    ReDim Preserve aData(i)
    aData(i) = Array(sName, rCell)
End Sub

示例文件mySumIf_TestDemo.xlsm

Answer 2

您可以尝试修改此代码

Sub test()
    
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim CollNames As Collection
    Dim Cella As Range
    Dim R As Long
    
    Set Sh1 = ThisWorkbook.Sheets("Foglio1") 'origine
    Set Sh2 = ThisWorkbook.Sheets("Foglio2") 'destinazione
    Set CollNames = New Collection
    With Sh1
        R = 1
        On Error Resume Next
        For Each Cella In .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row) 
            CollNames.Add Sh2.Cells(R, 1), CStr(Cella)
            If Err.Number = 0 Then
                CollNames(Cella) = Cella
                R = R + 1
            Else
                Err.Clear
            End If
            CollNames(Cella).Offset(0, 1) = CollNames(Cella).Offset(0, 1) + Cella.Offset(0, 1)
        Next Cella
        On Error GoTo 0
    End With
    Set Sh1 = Nothing
    Set Sh2 = Nothing
    Set CollNames = Nothing
    
End Sub

代码读取 Sh1 的 A 和 B 列中的数据，并在 Sh2 的相同列中报告结果。

需要修改 For Each 语句中的范围和偏移量。