时间戳

首页 > 解决方案 > 在循环vba中合并重复的行

excel - 在循环vba中合并重复的行

问题描述

我想将具有相同 A 和 C 列值的重复行组合起来，并对列 B 的单元格值求和（通过将 textbox2 的值从副本添加到原始值）。我的问题是关于循环中“如果”的条件。当我有重复项并仅添加新行时，它不会考虑这些条件。有一个更好的方法吗？


Private Sub CommandButton1_Enter()


ActiveSheet.Name = "Sheet1"  
Dim lastrow As Long

With Sheets("Sheet2")

 lastrow = .Cells(Rows.Count, "H").End(xlUp).Row

 For x = lastrow To 3 Step -1
   For y = 3 To lastrow
       
       If .Cells(x, 1).Value = .Cells(y, 1).Value And .Cells(x, 3).Value = .Cells(y, 3).Value And x > y Then
       
       .Cells(y, 8).Value = .Cells(y, 8).Value + TextBox2.Text
       .Cells(y, 2).Value = .Cells(y, 2).Value + TextBox2.Text
       .Rows(lastrow).EntireRow.Delete
           
      Else

       .Cells(lastrow + 1, 8).Value = TextBox2.Text
       .Cells(lastrow + 1, 2).Value = TextBox2.Text
       .Cells(lastrow + 1, 1).Value = TextBox1.Text
       .Cells(lastrow + 1, 3).Value = TextBox3.Text
       
         Exit For
      End If

   Next y
 Next x

End With

End Sub

这是数据的图片 在此处输入图像描述

H 列中没有空白单元格（我更改了字体的颜色以使其不可见）。

标签： excelvbafor-loopduplicates

解决方案

通过使用波浪号 ~ 连接 2 列来创建主键，并使用字典对象来定位重复项。

Option Explicit

Private Sub CommandButton1_Click()

    Dim wb As Workbook, ws As Worksheet
    Dim iLastRow As Long, iRow As Long, iTarget As Long

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet2")
    iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row

    Dim dict As Object, sKey As String
    Set dict = CreateObject("Scripting.Dictionary")

    ' build dictionary and
    ' consolidate any existing duplicates, scan up
    For iRow = iLastRow To 3 Step -1

        ' create composite primary key
        sKey = LCase(ws.Cells(iRow, 1).Value) & "~" & Format(ws.Cells(iRow, 3).Value, "yyyy-mm-dd")

        If dict.exists(sKey) Then
            iTarget = dict(sKey)
            ' summate and delete
            ws.Cells(iTarget, 2) = ws.Cells(iTarget, 2) + ws.Cells(iRow, 2)
            ws.Cells(iTarget, 8) = ws.Cells(iTarget, 8) + ws.Cells(iRow, 8)
            ws.Rows(iRow).EntireRow.Delete
        Else
            dict(sKey) = iRow
        End If
    Next

    ' add new record from form using dictionary to locate any existing
    iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
    sKey = LCase(TextBox1.Text) & "~" & Format(DateValue(TextBox3.Text), "yyyy-mm-dd")
    If dict.exists(sKey) Then
        iTarget = dict(sKey)
        ws.Cells(iTarget, 2) = ws.Cells(iTarget, 2) + TextBox2.Text
        ws.Cells(iTarget, 8) = ws.Cells(iTarget, 8) + TextBox2.Text
    Else
        iTarget = iLastRow + 1
        ws.Cells(iTarget, 1) = TextBox1.Text
        ws.Cells(iTarget, 2) = TextBox2.Text
        ws.Cells(iTarget, 3) = TextBox3.Text
        ws.Cells(iTarget, 8) = TextBox2.Text
    End If

End Sub

推荐阅读