☰

Найти повторяющиеся строки на основе двух столбцов и перенести результаты на другой рабочий лист.

tag-icon • tag-icon microsoft-excel-2007 vba
Найти повторяющиеся строки на основе двух столбцов и перенести результаты на другой рабочий лист.

У меня есть рабочий лист ("Saisie de Données"), содержащий данные в столбцах B и D, которые иногда являются дубликатами. Я хотел бы иметь возможность распознавать эти дубликаты и суммировать данные в столбцах G - V. Затем результат будет перенесен на другой рабочий лист ("Sommaire - Paie"), который получит недублирующиеся строки с их связанными данными и дублирующую строку с результатами суммы. Все столбцы остаются теми же на двух рабочих листах, за исключением столбца C, который не копируется на новый рабочий лист. Каждый раз при запуске макроса данные на втором рабочем листе ("Sommaire - Paie") будут перезаписываться.

Я приложил копию рабочего листа с данными для анализа («Saisie de Données») и предполагаемым результатом («Sommaire - Paie»), который я создал вручную.

Чтобы получить прикрепленный файл, следуйтеэта ссылка на дропбокс.

В настоящей трудовой книжке строк гораздо больше, но схема всегда одна и та же: имя работника и количество отработанных им часов в течение недели.

решение1

Мне помог парень по имени Йоё Цзян, и код работает отлично. Вот код, который я использовал:

Private Sub TestSumDuplicate()

Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = ThisWorkbook.Worksheets("Saisie de Données")
Set WS2 = ThisWorkbook.Worksheets("Sommaire - Paie (2)")

Dim oRange1 As Range
Dim oRange2 As Range
Dim tempRange As Range

Set oRange2 = WS2.Range("A29", "U110")
oRange2.ClearContents
Set oRange1 = WS1.Range("A30", "V553")

Dim i As Integer
Dim j As Integer
Dim t As Integer
Dim m As Integer
Dim n As Integer

Dim bFlag As Boolean

' j to record the current relative row location in oRange2
j = 1

For i = 0 To oRange1.Rows.Count - 1

bFlag = False '' to record if there is already a same category in oRange2.

If Not oRange1.Cells(i, 2) = "" Then
If Not oRange1.Cells(i, 2) = "Ligne Sommaire" Then

'' If it a row need to be check
For t = 1 To j
If oRange2.Cells(t, 3) = oRange1.Cells(i, 4) And oRange2.Cells(t, 2) = oRange1.Cells(i, 2) Then
bFlag = True

    '' Sum if duplicate
    For m = 0 To 18
    If Not oRange1.Cells(i, 7 + m) = "" Then
        oRange2.Cells(t, 6 + m) = oRange1.Cells(i, 7 + m) + oRange2.Cells(t, 6 + m)
    End If
    Next m

Exit For
End If
Next t

If bFlag = True Then
    bFlag = False
Else
    '' doesn't find a duplicate value
    oRange2.Cells(j, 1) = oRange1.Cells(i, 1)
    oRange2.Cells(j, 2) = oRange1.Cells(i, 2)

    For m = 4 To 25
     oRange2.Cells(j, m - 1) = oRange1.Cells(i, m)
    Next m

    j = j + 1
End If

End If
End If
Next i

End Sub

Связанный контент