查找匹配的行号 VBA
Find row number of match VBA
在 sheet 中，我有一个姓名列表，在另一列中有一个与之关联的金额。我需要在另一个 sheet 的专栏中不重复地写下这些名称。当名称重复时，我还需要对金额求和。
例如：
XXXX 20
YYYY 30
XXXX 10
我的结果应该是
XXXX 30
YYYY 30
我正在做一个 for 循环来遍历这些名字，如果我没有在结果列中写那个名字，我会写它。如果我已经写好了，我将不得不留在同一行并计算金额的总和。
问题是我尝试使用 Range.Find，但它总是 returns 什么都没有，即使名称已经写好了。
代码如下：
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
谢谢，
卡洛塔.
P.S。我是 VBA 的新手，所以我的代码可能会很乱
您可以尝试改编此代码
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语句中的范围和偏移量。
您不必遍历范围内的所有区域（大约 For Each area In Worksheets("XXX")...）。只需遍历范围内的单元格，范围对象就会将它们全部显示给您。
此外，不要将所有范围都写入宏。您每次都必须将代码更改为 select 个其他单元格。在 运行 宏之前 select 所需的单元格并使用 Selection 对象更容易（请不要担心这里有这么多文本 - 事实上，只有不到 30 行代码，所有其余的是给你的评论):
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
在 sheet 中，我有一个姓名列表，在另一列中有一个与之关联的金额。我需要在另一个 sheet 的专栏中不重复地写下这些名称。当名称重复时，我还需要对金额求和。 例如：
XXXX 20
YYYY 30
XXXX 10
我的结果应该是
XXXX 30
YYYY 30
我正在做一个 for 循环来遍历这些名字，如果我没有在结果列中写那个名字，我会写它。如果我已经写好了，我将不得不留在同一行并计算金额的总和。 问题是我尝试使用 Range.Find，但它总是 returns 什么都没有，即使名称已经写好了。
代码如下：
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
谢谢， 卡洛塔.
P.S。我是 VBA 的新手，所以我的代码可能会很乱
您可以尝试改编此代码
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语句中的范围和偏移量。
您不必遍历范围内的所有区域（大约 For Each area In Worksheets("XXX")...）。只需遍历范围内的单元格，范围对象就会将它们全部显示给您。
此外，不要将所有范围都写入宏。您每次都必须将代码更改为 select 个其他单元格。在 运行 宏之前 select 所需的单元格并使用 Selection 对象更容易（请不要担心这里有这么多文本 - 事实上，只有不到 30 行代码，所有其余的是给你的评论):
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