vba проблема с объединением ячеек с одинаковыми данными в трех столбцах в один ряд - PullRequest
Новая
       33

vba проблема с объединением ячеек с одинаковыми данными в трех столбцах в один ряд

0 голосов
/ 12 апреля 2019

Я написал макрос, в котором мне нужно объединить одни и те же тройки данных (в три столбца) в одну строку и подсчитать строки, в которых были эти тройки.Я написал этот код, но он неправильно посчитал строки.У меня также есть заголовок в двух первых строках этого листа.

Я уже пробовал этот код, но он не считается правильно: 

Dim rw As Long
Dim lr As Long

lr = Rows.Count

For rw = Rows.Count To 3 Step -1

    If Cells(rw, 1).Value2 <> Cells(rw - 1, 1).Value2 And _
       Cells(rw, 2).Value2 <> Cells(rw - 1, 2).Value2 And rw < lr And _
       Cells(rw, 3).Value2 <> Cells(rw - 1, 3).Value2 And rw < lr Then

         Cells(rw, 4) = Application.Count(Range(Cells(rw, 4), Cells(lr, 4)))
         Cells(rw + 1, 1).Resize(lr - rw, 1).EntireRow.Delete
         lr = rw + 1
    End If

Next rw

Это весь мой лист:

Дата;Критическое;сырье;SFG;

12/04/2019; Y; 147833; 594673

12/04/2019; Y; 147833; 656555

12/04/2019; Y; 147833; 780319

12/04/2019; Y; 147833; 842201

12/04/2019; Y; 147833; 904083

12/04/2019;Y; 147833; 965965

12/04/2019; Y; 147833; 1027847

12/04/2019; Y; 147833; 1089729

12/04/2019; Y; 151753; 1151611

12/04/2019; Y; 151753; 1275375

12/04/2019; Y; 151753; 1337257

12/04 /2019; Y; 151753; 1399139

12/04/2019; Y; 151753; 1461021

12/04/2019; Y; 151753; 1584785

Я хочу получить это:

12/04/2019; Y; 147833; 8

12/04/2019; Y; 151753; 6

1 Ответ

0 голосов
/ 14 апреля 2019
  • Похоже, вы хотите сгруппировать по первым трем столбцам и агрегировать путем подсчета.
  • Сохраните копию рабочей книги перед запуском (на всякий случай).В приведенном ниже коде предполагается, что ваши данные находятся на рабочем листе с именем "Sheet2" (измените на тот, который вызывается в вашем случае).
  • Вместо того, чтобы зацикливаться на отдельных строках, мы используем некоторые вспомогательные столбцы (если у вас есть данные после столбцаD, он может быть перезаписан вспомогательными столбцами), а затем отфильтрован по значениям в этих вспомогательных столбцах. 
Option Explicit

Private Sub GroupByFirstThreeColumnsAndCount()

    With ThisWorkbook.Worksheets("Sheet2")
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        With .Range("F3:F" & lastRow)

            ' Add groupByKeys
            .Formula = "=A3&""|""&B3&""|""&C3" ' Newer versions of Excel have TEXTJOIN. Use instead, if you have it.

            ' Add total count
            .Offset(0, -1).Formula = "=COUNTIF(" & .Address & "," & .Cells(1, 1).Address(rowabsolute:=False) & ")"

            ' Add cumulative/expanding count
            .Offset(0, 1).Formula = "=COUNTIF(" & .Cells(1, 1).Address & ":" & .Cells(1, 1).Address(rowabsolute:=False) & "," & .Cells(1, 1).Address(rowabsolute:=False) & ")"

            Dim rangeToFilter As Range
            Set rangeToFilter = .Offset(0, -1).Resize(, 3)
        End With

        rangeToFilter.Value2 = rangeToFilter.Value2
        rangeToFilter.Offset(-1, 0).Resize(rangeToFilter.Rows.Count + 1, rangeToFilter.Columns.Count).AutoFilter Field:=3, Criteria1:="<>1"

        Dim rowsToDelete As Range
        On Error Resume Next
        Set rowsToDelete = rangeToFilter.SpecialCells(xlCellTypeVisible).EntireRow
        On Error GoTo 0

        If Not (rowsToDelete Is Nothing) Then rowsToDelete.Delete
        rangeToFilter.AutoFilter

        .Columns("F:G").Clear
    End With
End Sub

Дает ожидаемый результат, я думаю:

Macro output

...