Question

Я хотел бы создать макрос, который копирует числа, относящиеся к одной и той же категории, и складывает их отдельно для каждой категории.Например, ячейки в столбце c содержат название продукта, а в 4 столбцах справа указано количество проданных продуктов.Я хотел бы сложить все записи в количестве проданных продуктов, которые подпадают под один и тот же продукт, вместе для каждого продукта и записать его в предопределенную ячейку.До сих пор я придумал это

Sub find()
Dim XXX As Range
Dim myTotal As Long
Dim name As String
Dim name2 As String

name = Range("C2")

For Each XXX In Range("C2:C99999")
name2 = ActiveCell.Value

If name <> name2 Then
    Dim aa As Integer
    aa = 1
    Cells(aa, 8).Value = name
    Cells(aa, 9).Value = myTotal
    name = name2
    myTotal = 0
    aa = aa + 1
End If

If InStr(XXX.Value, name2) > 0 Then
    myTotal = myTotal + XXX.Offset(0, 4).Value
End If

Next XXX

End Sub

Любые советы или рекомендации будут оценены, и я надеюсь, что объяснение имеет смысл.

VBasic2008 · Answer 1 · 02 марта 2019

Функция словаря SumIf

VBA Dictionary Solution

Кредиты Тиму Уильямсу и его решению .
Зачем OP хотеть решение VBA, когда есть совершенно хорошее решение Excel?Когда существует десятки тысяч записей и столько же или много раз больше формул, рабочая книга становится медленной.Таким образом, добавляя формулу SUMIF, мы добавляем еще одну группу, которая еще больше замедляется.И мы не знаем уникальных значений, которые мы могли бы найти, используя другую формулу серьезного замедления.
Так что VBA сделает это за доли секунды или нет?Я создал новый лист с 60000 записями и 1000 уникальными, чтобы попытаться это доказать.
SumIf Решение: Первой идеей было настроить все диапазоны, получить уникальные значения, используя Advanced Filter и затем используйте Worksheetfunction.SumIf.SumIf заняло свое время, 17 с, а когда я добавил некоторые формулы, оно превысило 20 с.
Решение для цикла с массивом: Этот снова использовал Advanced Filterно на этот раз идея состояла в том, чтобы поместить все в массивы и циклически их перебрать и добавить значения в другой массив один за другим.На этот раз цикл занял свое время.После некоторой настройки он уменьшился до 13 с и остался там даже после добавления формул.
Advanced Filter действительно скопировал уникальные значения менее чем за 0,2 с в соответствующий диапазон, но остальное заняло слишком много времени.
Словарь Решение: Решение Тима Уильямса первоначально сделало все это за 2,5 секунды.Как это возможно, подумал я, Advanced Filter - бог уникальных ценностей.Ну, нет, или, в лучшем случае, это только один из них.Я видел эту строку в цикле в коде: dict(names(r, 1)) = dict(names(r, 1)) + nums(r, 1).Казалось, что он делал тяжелую работу за долю секунды, что заставило меня исследовать ( Словарь объекта (Microsoft) , Словарь Excel VBA: Полное руководство (Пол Келли) и произвестирешение.

Код

Sub SumIfToTarget3() ' Array Dictionary ... 0.2-0.3s

    ' Name
    Const cNsht As Variant = "Sheet2"   ' Name Worksheet Name/Index
    Const cNrow As Long = 1             ' Name First Row Number
    Const cNcol As Long = 3             ' Name Column Number
    Const cVcol As Long = 7             ' Value Column Number
    ' Target
    Const cTsht As Variant = "Sheet2"   ' Target Worksheet Name/Index
    Const cTrow As Long = 1             ' Target First Row Number
    Const cUcol As Long = 8             ' Unique Column Number
    Const cUnique As String = "Unique"  ' Unique Column Header
    Const cSumIf As String = "Total"    ' SumIf Column Header

    ' Create a reference to the Dictionary Object.
    '*******************************************************
    ' Early Binding (0.1s Faster)                          *
    ' You have to go to Tools>References and check (create *
    ' a reference to) "Microsoft Scripting Runtime" .      *
'    Dim dict As New Dictionary '                           *
    '*******************************************************
    '**************************************************
    ' Late Binding (0.1s Slower)                      *
    ' You don't need to create a reference.           *
    Dim dict As Object '                              *
    Set dict = CreateObject("Scripting.Dictionary") ' *
    '**************************************************

    Dim dk As Variant    ' Dictionary 'Counter' (For Each Control Variable)
    Dim CurV As Variant  ' Current Value
    Dim rngN As Range    ' Name Column Range, Last Used Cell in Name Column,
                         ' Name Range with Headers, Name Range
    Dim rngV As Range    ' Value Range
    Dim rngT As Range    ' Target Columns Range, Target Range
    Dim vntN As Variant  ' Name Array
    Dim vntV As Variant  ' Value Array
    Dim vntT As Variant  ' Target Array
    Dim i As Long        ' Name/Value Array Element (Row) Counter,
                         ' Target Array Row Counter, Target Array Rows Count
                         ' (Dictionary Items Count)

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Handle Errors.
    On Error GoTo ErrorHandler

    ' In Unique Column
    With ThisWorkbook.Worksheets(cTsht).Columns(cUcol)
        ' Create a reference to Target Columns Range (rngT) i.e. the range in
        ' Unique Column (cUcol) from Target First Row (cTrow) to the bottom row
        ' of Target Worksheet (cTsht), resized by a column for SumIf Column (2).
        Set rngT = .Resize(.Rows.Count - cTrow + 1, 2).Offset(cTrow - 1)
    End With
    ' Clear contents of Target Columns Range (rngT).
    rngT.ClearContents
    ' Write Unique Column Header to 1st Cell of Target Columns Range.
    rngT.Cells(1) = cUnique
    ' Write SumIf Column Header to 2nd Cell of Target Columns Range.
    rngT.Cells(2) = cSumIf

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Calculate Last Used Cell in Name Column.
        Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Name Range with headers.
        Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
    End With
    ' Calculate Name Range (without headers).
    Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
    ' Copy Name Range (rngN) to Name Array (vntN).
    vntN = rngN
    ' Calculate Value Range (without headers).
    Set rngV = rngN.Offset(, cVcol - cNcol)
    ' Copy Value Range (rngV) to Value Array (vntV).
    vntV = rngV

    ' Loop through elements (rows) of Name Array.
    For i = 1 To UBound(vntN)
        ' Write element in current row (i) of Value Array (vntV) to Current
        ' Value.
        CurV = vntV(i, 1)
        ' Check if Current Value (CurV) is NOT a number.
        If Not IsNumeric(CurV) Then
            ' Assign 0 to Current Value.
            CurV = 0
        End If
        ' Add current element (row) in Name Array (vntN) and Current Value
        ' to the Dictionary. If the key to be added is new (not existing),
        ' the new key and the item will be added. But if the key exists, then
        ' the existing item will be increased by the value of the new item.
        ' This could be called "The Dictionary SumIf Feature".
        dict(vntN(i, 1)) = dict(vntN(i, 1)) + CurV
    Next

    ' Reset Name/Value Array Element (Row) Counter to be used as
    ' Target Array Row Counter.
    i = 0
    ' Resize Target Array to the number of items in the Dictionary.
    ReDim vntT(1 To dict.Count, 1 To 2)
    ' Loop through each Key (Item) in the Dictionary.
    For Each dk In dict.Keys
        ' Increase Target Array Row Counter (count Target Array Row).
        i = i + 1
        ' Write current Dictionary Key to element in current (row) and
        ' 1st column (Unique) of Target Array.
        vntT(i, 1) = dk
        ' Write current Dictionary Item to element in current (row) and
        ' 2nd column (SumIf) of Target Array.
        vntT(i, 2) = dict(dk)
    Next

    ' Calculate Target Range (rngT) from second row (2) of Target Columns
    ' Range (rngT) resized by Target Array Rows Count (i).
    Set rngT = rngT.Rows(2).Resize(i)
    ' Copy Target Array (vntT) to Target Range (rngT).
    rngT = vntT

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:

    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

SUMIF ?! Решение Excel

Это больше вопрос, чем ответ:

Можно ли это рассматривать как упрощенное визуальное представление того, чего вы пытаетесь достичь?

В ячейке I2 можно использовать следующую формулу:

=SUMIF(C$2:C$16,H2,G$2:G$16)

Настройка диапазонов и копирование вниз.

Усовершенствованное решение для цикла с матрицей фильтров

Sub SumIfToUnique2() ' Advanced Filter & Loop through Arrays, Add ... 13s

    ' Name
    Const cNsht As Variant = "Sheet2"   ' Name Worksheet Name/Index
    Const cNrow As Long = 1             ' Name First Row Number
    Const cNcol As Long = 3             ' Name Column Number
    Const cVcol As Long = 7             ' Value Column Number
    ' Unique
    Const cUsht As Variant = "Sheet2"   ' Unique Worksheet Name/Index
    Const cUrow As Long = 1             ' Unique First Row Number
    Const cUcol As Long = 8             ' Unique Column Number
    Const cSumIf As String = "Total"    ' SumIf Column Header
    Const cUnique As String = "Unique"  ' Unique Column Header

    Dim rngN As Range    ' Name Column Range, Last Used Cell in Name Column,
                         ' Name Range with Headers, Name Range
    Dim rngV As Range    ' Value Range
    Dim rngU As Range    ' Unique Column Range, Last Used Cell in Unique Column,
                         ' Unique Range
    Dim vntN As Variant  ' Name Array
    Dim vntV As Variant  ' Value Array
    Dim vntU As Variant  ' Unique Array
    Dim vntS As Variant  ' SumIf Array
    Dim i As Long        ' Name/Value Array Row Counter
    Dim k As Long        ' Unique/SumIf Array Row Counter
    Dim strN As String   ' Current Name (in Name Array)

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Handle Errors.
    On Error GoTo ErrorHandler

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Create a reference to Name Column Range (rngN) i.e. the range in
        ' Name Column (cNcol) from Name First Row (cNrow) to the bottom row
        ' of Name Worksheet (cNsht).
        Set rngN = .Resize(.Rows.Count - cNrow + 1).Offset(cNrow - 1)
    End With

    ' In Unique Column
    With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
        ' Create a reference to Unique Column Range (rngU) i.e. the range in
        ' Unique Column (cUcol) from Unique First Row (cUrow) to the bottom row
        ' of Unique Worksheet (cUsht).
        Set rngU = .Resize(.Rows.Count - cUrow + 1).Offset(cUrow - 1)
    End With
    ' Clear contents of Unique Column Range (rngU).
    rngU.ClearContents
    ' Calculate SumIf Column Range.
    ' Clear contents of SumIf Column Range.
    rngU.Offset(, 1).ClearContents

    ' Write unique values from Name Column Range (rngN), starting with the
    ' header (aka title), to Unique Column Range (rngU), starting in its
    ' First Row (1).
    rngN.AdvancedFilter xlFilterCopy, , rngU.Resize(1), True
    ' Calculate Unique Header Cell Range.
    ' Write Unique Column Header to Unique Header Cell Range.
    rngU.Resize(1) = cUnique
    ' Calculate SumIf Header Cell Range.
    ' Write SumIf Column Header to SumIf Header Cell Range.
    rngU.Resize(1).Offset(, 1) = cSumIf

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Calculate Last Used Cell in Name Column.
        Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Name Range with headers.
        Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
    End With
    ' Calculate Name Range (without headers).
    Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
    ' Copy Name Range (rngN) to Name Array (vntN).
    vntN = rngN
    ' Calculate Value Range (without headers).
    Set rngV = rngN.Offset(, cVcol - cNcol)
    ' Copy Value Range (rngV) to Value Array (vntV).
    vntV = rngV

    ' In Unique Column
    With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
        ' Calculate Last Used Cell in Unique Column.
        Set rngU = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Unique Range with headers.
        Set rngU = .Cells(cUrow).Resize(rngU.Row - cUrow + 1)
    End With
    ' Calculate Unique Range (without headers).
    Set rngU = rngU.Resize(rngU.Rows.Count - 1).Offset(1)
    ' Copy Unique Range (rngU) to Unique Array (vntU).
    vntU = rngU

    ' Resize SumIf Array to size of Unique Array.
    ReDim vntS(1 To UBound(vntU), 1 To 1)
    ' Loop through elements (rows) of Name Array.
    For i = 1 To UBound(vntN)
        ' Write current value in Name Array (vntN) to Current Name (strN).
        strN = vntN(i, 1)
        ' Loop through elements (rows) of Unique/SumIf Array.
        For k = 1 To UBound(vntU)
            If vntU(k, 1) = strN Then
                vntS(k, 1) = vntS(k, 1) + vntV(i, 1)
                Exit For
            End If
        Next
    Next

    ' Calculate SumIf Range (from Unique Range (rngU)).
    ' Copy SumIf Array to SumIf Range.
    rngU.Offset(, 1) = vntS

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:

    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

Усовершенствованный фильтрSumIf Solution

Sub SumIfToUnique1() ' Advanced Filter & SumIf on Ranges ... 17-22s

    ' Name
    Const cNsht As Variant = "Sheet2"   ' Name Worksheet Name/Index
    Const cNrow As Long = 1             ' Name First Row Number
    Const cNcol As Long = 3             ' Name Column Number
    Const cVcol As Long = 7             ' Value Column Number
    ' Unique
    Const cUsht As Variant = "Sheet2"   ' Unique Worksheet Name/Index
    Const cUrow As Long = 1             ' Unique First Row Number
    Const cUcol As Long = 8             ' Unique Column Number
    Const cSumIf As String = "Total"    ' SumIf Column Header
    Const cUnique As String = "Unique"  ' Unique Column Header

    Dim rngN As Range    ' Name Column Range, Last Used Cell in Name Column,
                         ' Name Range with Headers, Name Range
    Dim rngV As Range    ' Value Range
    Dim rngU As Range    ' Unique Column Range, Last Used Cell in Unique Column,
                         ' Unique Range
    Dim vntU As Variant  ' Unique Array
    Dim vntS As Variant  ' SumIf Array
    Dim i As Long        ' Unique Array Row Counter

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Handle Errors.
    On Error GoTo ErrorHandler

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Create a reference to Name Column Range (rngN) i.e. the range in
        ' Name Column (cNcol) from Name First Row (cNrow) to the bottom row
        ' of Name Worksheet (cNsht).
        Set rngN = .Resize(.Rows.Count - cNrow + 1).Offset(cNrow - 1)
    End With

    ' In Unique Column
    With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
        ' Create a reference to Unique Column Range (rngU) i.e. the range in
        ' Unique Column (cUcol) from Unique First Row (cUrow) to the bottom row
        ' of Unique Worksheet (cUsht).
        Set rngU = .Resize(.Rows.Count - cUrow + 1).Offset(cUrow - 1)
    End With
    ' Clear contents of Unique Column Range (rngU).
    rngU.ClearContents
    ' Calculate SumIf Column Range.
    ' Clear contents of SumIf Column Range.
    rngU.Offset(, 1).ClearContents

    ' Write unique values from Name Column Range (rngN), starting with the
    ' header (aka title), to Unique Column Range (rngU), starting in its
    ' First Row (1).
    rngN.AdvancedFilter xlFilterCopy, , rngU.Resize(1), True
    ' Calculate Unique Header Cell Range.
    ' Write Unique Column Header to Unique Header Cell Range.
    rngU.Resize(1) = cUnique
    ' Calculate SumIf Header Cell Range.
    ' Write SumIf Column Header to SumIf Header Cell Range.
    rngU.Resize(1).Offset(, 1) = cSumIf

    ' In Name Column
    With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
        ' Calculate Last Used Cell in Name Column.
        Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Name Range with headers.
        Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
    End With
    ' Calculate Name Range (without headers).
    Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
    ' Calculate Value Range (without headers).
    Set rngV = rngN.Offset(, cVcol - cNcol)

    ' In Unique Column
    With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
        ' Calculate Last Used Cell in Unique Column.
        Set rngU = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
        ' Calculate Unique Range with headers.
        Set rngU = .Cells(cUrow).Resize(rngU.Row - cUrow + 1)
    End With
    ' Calculate Unique Range (without headers).
    Set rngU = rngU.Resize(rngU.Rows.Count - 1).Offset(1)
    ' Copy Unique Range to Unique Array.
    vntU = rngU

    ' Resize SumIf Array to size of Unique Array.
    ReDim vntS(1 To UBound(vntU), 1 To 1)

    ' Loop through elements (rows) of SumIf/Unique Array.
    For i = 1 To UBound(vntS)
        ' Write result of SumIf funtion to current element (row) of SumIf Array.
        vntS(i, 1) = WorksheetFunction.SumIf(rngN, vntU(i, 1), rngV)
    Next

    ' Calculate SumIf Range (from Unique Range (rngU)).
    ' Copy SumIf Array to SumIf Range.
    rngU.Offset(, 1) = vntS

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:

    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

Tim Williams · Answer 2 · 02 марта 2019

Вот более быстрый базовый подход:

Sub find()

    Dim dict As Object, names, nums, r As Long
    Dim sht As Worksheet

    Set sht = ActiveSheet

    Set dict = CreateObject("scripting.dictionary")

    names = Range("C2:C99999").Value
    nums = Range("C2:C99999").Offset(0, 4).Value

    For r = 1 To UBound(names)
        dict(names(r, 1)) = dict(names(r, 1)) + nums(r, 1)
    Next r

    WriteCounts dict, sht.Range("J1")

End Sub

Sub WriteCounts(dict As Object, rngStart As Range)
    Dim k
    For Each k In dict.keys
        rngStart.Value = k
        rngStart.Offset(0, 1).Value = dict(k)
        Set rngStart = rngStart.Offset(1, 0)
    Next k
End Sub

Копирование данных из ячеек и добавление их в Excel Visual Basic

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

Ответы [ 2 ]

Функция словаря SumIf

VBA Dictionary Solution

SUMIF ?! Решение Excel

Усовершенствованное решение для цикла с матрицей фильтров

Усовершенствованный фильтрSumIf Solution

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Копирование данных из ячеек и добавление их в Excel Visual Basic

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

Ответы [ 2 ]

Функция словаря SumIf

VBA Dictionary Solution

SUMIF ?! Решение Excel

Усовершенствованное решение для цикла с матрицей фильтров

Усовершенствованный фильтрSumIf Solution

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Нет похожих вопросов