Объедините повторяющиеся строки в al oop vba - PullRequest
Новая
       150

Объедините повторяющиеся строки в al oop vba

0 голосов
/ 09 мая 2020

Я хочу объединить повторяющиеся строки с одинаковыми значениями столбцов A и C и суммировать значения их ячеек для столбца B (путем добавления значения textbox2 из дубликата в оригинал). Моя проблема связана с состоянием «Если» в L oop. Он не учитывает те условия, когда у меня есть дубликаты, а просто добавляю новую строку. Есть ли лучший способ сделать это? 


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 нет пустой ячейки (я изменил цвет шрифта, чтобы сделать его невидимым).

1 Ответ

1 голос
/ 12 мая 2020

Создайте первичный ключ, соединив 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
...