Оптимизация макроса для организации данных - PullRequest
Новая
       0

Оптимизация макроса для организации данных

1 голос
/ 01 марта 2020

У меня есть некоторый csv-экспорт из базы данных, которую я хочу организовать, я создал макрос VBA в Excel, который занимает около 40 минут до конца sh, и я хотел бы знать, как его оптимизировать (в основном, учиться).

Представьте, что у вас есть разные фруктовые магазины, в которых продаются разные фрукты, и вы получите CSV:

Worksheets ("Temp1") = 

Shop 1 ¦ Apple ¦ 10
Shop 1 ¦ Melon ¦ 20
Shop 2 ¦ Apple ¦ 30
Shop 3 ¦ Mango ¦ 40
Shop 1 ¦ Mango ¦ 50

Я уже создал лист, например:

Worksheets (NameOfWorkbook) = 

      ¦Shop 1¦Shop 2¦Shop 3 
Apple
Melon
Mango

И я хочу макрос, который заполняет последний лист, например:

Worksheets ( NameOfWorkbook) = 

      ¦Shop 1¦Shop 2¦Shop 3 
Apple ¦10    ¦30
Melon ¦20    ¦
Mango ¦50    ¦      ¦40

Таким образом, макрос, который я использую, является тройным для l oop как: 

For i = 1 To 1500
    For j = 1 To 150
       For k = 1 To 300
       If Worksheets("Temp1").Cells(i, 1) = Worksheets(NameOfWorkbook).Cells(1, j) And Worksheets("Temp1").Cells(i, 2) = Worksheets(NameOfWorkbook).Cells(k, 1) Then
            Worksheets(NameOfWorkbook).Cells(k, j) = Worksheets("Temp1").Cells(i, 3)
           End If
      Next k
    Next j
Next i

Я хотел бы знать, чтобы оптимизировать код, любая помощь будет очень ценим.

Большое спасибо.

С уважением.

РЕДАКТИРОВАТЬ

Большое спасибо за ваши комментарии и ответы, высоко ценится .

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

Ниже приведен полный код:

рабочий процесс имеет вид:

Шаг 0: отключить приложения, которые могут снизить производительность, создать 2no временных листов «Temp1» и «Temp2», чтобы упорядочить информацию и создать лист, где будет отображаться вся информация, называя ее фактические дата и время.

Шаг 1: Откройте отчет хранилища 1 .csv и импортируйте данные, поскольку не все столбцы необходимо импортировать

Шаг 2: Откройте отчет хранилища 2 .csv и импортируйте данные данные, так как не все столбцы необходимо импортировать

Шаг 3: Открыть отчет .csv и импортировать данные в «Temp1»

Шаг 4: Поскольку некоторые данные дублируются (Пример: I продаю 3 яблока из магазина 1 в день 1 и 4 яблока из магазина 1 в день 5), я присоединяюсь к значениям яблок Shop1 &&, чтобы удалить дубликаты, и добавляю значения для яблок Shop1 && на общую сумму 7 и th. ru Разделить Магазин1 и Яблоки в разные столбцы

Шаг 5: Объединить акции, так как дата не важна, но общая стоимость

Шаг 6: Разделить ценности магазина и фруктов

Шаг 7. Значение в отчете не нужно отображать, поэтому я заменяю его из импортированного столбца со склада (Пример: в report.csv «яблоки» отображаются как «AP» и «Man go»). "as" MG ")

Шаг 8: Название магазинов было скопировано на лист" Temp2 ". Этот код предназначен для организации их в алфавитном порядке, прежде чем копировать их в column1 окончательного листа, также я изменяю ширину и ориентацию столбцов. для простоты чтения

Шаг 9: Заполненный код, который я заменил своим из Dy.Lee, время выполнения сократилось на 40 минут до менее чем 30 секунд c (Я искренне впечатлен и благодарен, спасибо, действительно спасибо)

Шаг 10: Удалить вспомогательные листы и повторно активировать приложения

Однако после использования кода DY.Lee значения заполненного кода отображаются из строки 303 и b elow, не соответствует их магазину и фруктам (?) 

Sub Import()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim NameOfWorkbook As String
Dim arr As Variant
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add(After:=ActiveSheet).Name = "Temp1"
Sheets.Add(After:=ActiveSheet).Name = "Temp2"
Sheets.Add(After:=ActiveSheet).Name = "Stock at " & Format(Now, "DD-MM-YY HH-MM")
NameOfWorkbook = ActiveSheet.Name

'Step 1 open the Warehouse 1 book to import the data into NameOfWorkbook

FileToOpen = Application.GetOpenFilename(Title:="Select Warehouse 1 stock report in csv format")
    If FileToOpen <> False Then
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    OpenBook.Sheets(1).Columns(3).Copy Destination:=ThisWorkbook.Sheets(NameOfWorkbook).Columns(1)
    OpenBook.Sheets(1).Columns(4).Copy Destination:=ThisWorkbook.Sheets(NameOfWorkbook).Columns(2)
    OpenBook.Sheets(1).Columns(7).Copy Destination:=ThisWorkbook.Sheets(NameOfWorkbook).Columns(3)
    ThisWorkbook.Sheets(NameOfWorkbook).Range("C1").Value = "Warehouse 1 Stock Available"
    OpenBook.Close False
    End If

'Step 2 open the Warehouse 2 book to import the data into NameOfWorkbook

FileToOpen = Application.GetOpenFilename(Title:="Select Warehouse 2 stock report in csv format")
    If FileToOpen <> False Then
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    OpenBook.Sheets(1).Columns(7).Copy Destination:=ThisWorkbook.Sheets(NameOfWorkbook).Columns(4)
    ThisWorkbook.Sheets(NameOfWorkbook).Range("D1").Value = "Warehouse 2 Yard Stock Available"
    OpenBook.Close False
    End If

Sheets(NameOfWorkbook).Columns("A:D").sort key1:=Range("B2"), _
      order1:=xlAscending, Header:=xlYes

'Step 3 open the stock book to import the data into Temp1

FileToOpen = Application.GetOpenFilename(Title:="Select Current Hires report in csv format")
    If FileToOpen <> False Then
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    arr = OpenBook.Sheets(1).Range("A1").CurrentRegion
    rowCount = UBound(arr, 1)
    columnCount = UBound(arr, 2)
    ThisWorkbook.Sheets("Temp1").Range("A1").Resize(rowCount, columnCount).Value = arr
    OpenBook.Close False
    End If

'Step 4 join Site number with item for join stock from different days

Dim arr2 As Variant
Dim i As Long, SiteName As Variant

arr2 = ThisWorkbook.Sheets("Temp1").Range("A1").CurrentRegion
    For i = LBound(arr2) To UBound(arr2)
    SiteName = split(arr2(i, 2), " - ")
    arr2(i, 1) = SiteName(UBound(SiteName)) & " && " & ThisWorkbook.Sheets("Temp1").Cells(i, 4).Value
    arr2(i, 2) = ThisWorkbook.Sheets("Temp1").Cells(i, 7).Value
    Next i

rowCount = UBound(arr2, 1)
columnCount = UBound(arr2, 2)
ThisWorkbook.Sheets("Temp1").Range("A1").Resize(rowCount, columnCount).Value = arr2
ThisWorkbook.Sheets("Temp1").Columns("c:M").EntireColumn.Delete

'Step 5 join stock from same site sent different days

Dim WorkRng As Range
Dim Dic As Variant
On Error Resume Next
Set WorkRng = Range("A2:B5000")
Set Dic = CreateObject("Scripting.Dictionary")
arr = WorkRng.Value
For i = 1 To UBound(arr, 1)
    Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 2)
Next
WorkRng.ClearContents
WorkRng.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.transpose(Dic.Keys)
WorkRng.Range("B1").Resize(Dic.Count, 1) = Application.WorksheetFunction.transpose(Dic.items)



'Step 6 Separate site and material
arr3 = ThisWorkbook.Sheets("temp1").Range("A1").CurrentRegion
For i = 2 To UBound(arr3, 1)
    ThisWorkbook.Sheets("Temp1").Cells(i, 3) = ThisWorkbook.Sheets("Temp1").Cells(i, 2)
    RESULT = split(ThisWorkbook.Sheets("Temp1").Cells(i, 1), " && ")
    ThisWorkbook.Sheets("Temp1").Cells(i, 1) = RESULT(0)
    ThisWorkbook.Sheets("Temp1").Cells(i, 2) = RESULT(1)
    Next

'Step 7 replace item code with name

arr4 = ThisWorkbook.Sheets("temp1").Range("A1").CurrentRegion
For i = 2 To UBound(arr4, 1)
    For j = 2 To 300
        If Worksheets("Temp1").Cells(i, 2) = Worksheets(NameOfWorkbook).Cells(j, 1) Then
            Worksheets("Temp1").Cells(i, 2) = Worksheets(NameOfWorkbook).Cells(j, 2)
            End If
    Next j
Next i

'ThisWorkbook.Sheets(NameOfWorkbook).Columns("A:A").EntireColumn.Delete

'Step 8 copy and order stock

Sheets("temp2").Range("a1:a5000").Value = Sheets("Temp1").Range("a1:a5000").Value
Sheets("temp2").Columns(1).RemoveDuplicates Columns:=Array(1)
ThisWorkbook.Sheets("Temp2").Columns("A:A").sort key1:=ThisWorkbook.Sheets("Temp2").Range("A2"), order1:=xlAscending, Header:=xlYes



For i = 5 To 100
    Sheets(NameOfWorkbook).Cells(1, i).Value = Sheets("temp2").Cells(i, 1).Value
    Next

Sheets(NameOfWorkbook).Rows(1).orientation = 90
Worksheets(NameOfWorkbook).Columns().columnwidth = 3
Worksheets(NameOfWorkbook).Columns("B").columnwidth = 50
Worksheets(NameOfWorkbook).Columns("C").columnwidth = 6
Worksheets(NameOfWorkbook).Columns("D").columnwidth = 6
Worksheets(NameOfWorkbook).Columns("A").Hidden = True

'Step 8 populate the main sheet

'For i = 1 To 1500
'    For j = 1 To 150
'       For k = 1 To 300
'       If Worksheets("Temp1").Cells(i, 1) = Worksheets(NameOfWorkbook).Cells(1, j) And Worksheets("Temp1").Cells(i, 2) = Worksheets(NameOfWorkbook).Cells(k, 1) Then
'            Worksheets(NameOfWorkbook).Cells(k, j) = Worksheets("Temp1").Cells(i, 3)
'            End If
'       Next k
'    Next j
'Next i


    Dim c As Object ' Dictionary
    Dim r As Object ' Dictionary
    Dim Ws As Worksheet
    Dim toWs As Worksheet
    Dim vDB, vR()
    Dim k As Long
    Dim x As Long, y As Long


    Set Ws = Sheets("Temp1")
    Set toWs = Sheets(NameOfWorkbook)

    Set c = CreateObject("Scripting.Dictionary") 'shops
    Set r = CreateObject("Scripting.Dictionary") 'fruit

    vDB = Ws.Range("a1").CurrentRegion

    For i = 2 To UBound(vDB, 1) 'if have header in sheet temp1 then i start with 2
        If Not c.Exists(vDB(i, 1)) Then
            k = k + 1
            c.Add vDB(i, 1), k  'Shop
        End If
        If Not r.Exists(vDB(i, 2)) Then
            j = j + 1
            r.Add vDB(i, 2), j  'Fruit
        End If
    Next i
    ReDim vR(1 To j, 1 To k)
    For i = 2 To UBound(vDB, 1) 'if have header in sheet temp1 then i start with 2
        x = c.Item(vDB(i, 1))
        y = r.Item(vDB(i, 2))
        vR(y, x) = vR(y, x) + vDB(i, 3)
    Next i

    With toWs
        .Range("a1").CurrentRegion.Clear
        .Range("a2").Resize(j, 1) = WorksheetFunction.transpose(r.Keys)
        .Range("b1").Resize(1, k) = c.Keys
        .Range("b2").Resize(j, k) = vR
    End With

'Step 9 delete auxiliar sheets

'ThisWorkbook.Sheets("Temp1").Delete
'ThisWorkbook.Sheets("Temp2").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub
'

Пожалуйста, найдите файлы:

https://drive.google.com/file/d/1JBwmwIsqB5XrJpYH2nmROF8MfZeOXgkw/view?usp=sharing https://drive.google.com/file/d/1fskK_vg6qgBLX1p3MBDvys0_m5m5fyFG/view?usp=sharing https://drive.google.com/file/d/1qtijaWltQnVBhdeX6h71lMNKWirx7AGw/view?usp=sharing https://drive.google.com/file/d/12GCx_aoaMCHKp51JD6wQk9AXtu5ikTA-/view?usp=sharing

1 Ответ

0 голосов
/ 01 марта 2020

Есть способы использовать сводную таблицу, оператор sql и последний словарь. Я использовал метод словаря. 

Sub test()
    Dim c As Object ' Dictionary
    Dim r As Object ' Dictionary
    Dim Ws As Worksheet
    Dim toWs As Worksheet
    Dim vDB, vR()
    Dim i As Long, k As Long,  j As Long
    Dim x As Long, y As Long


    Set Ws = Sheets("Temp1")
    Set toWs = Sheets("NameOfWorkbook")

    Set c = CreateObject("Scripting.Dictionary") 'shops
    Set r = CreateObject("Scripting.Dictionary") 'fruit

    vDB = Ws.Range("a1").CurrentRegion

    For i = 1 To UBound(vDB, 1) 'if have header in sheet temp1 then i start with 2
        If Not c.Exists(vDB(i, 1)) Then
            k = k + 1
            c.Add vDB(i, 1), k  'Shop
        End If
        If Not r.Exists(vDB(i, 2)) Then
            j = j + 1
            r.Add vDB(i, 2), j  'Fruit
        End If
    Next i
    ReDim vR(1 To j, 1 To k)
    For i = 1 To UBound(vDB, 1) 'if have header in sheet temp1 then i start with 2
        x = c.Item(vDB(i, 1))
        y = r.Item(vDB(i, 2))
        vR(y, x) = vR(y, x) + vDB(i, 3)
    Next i

    With toWs
        .Range("a1").CurrentRegion.Clear
        .Range("a2").Resize(j, 1) = WorksheetFunction.Transpose(r.Keys)
        .Range("b1").Resize(1, k) = c.Keys
        .Range("b2").Resize(j, k) = vR
    End With


End Sub

Отредактировано 

Dim c As Object ' Dictionary
Dim r As Object ' Dictionary
Dim Ws As Worksheet
Dim toWs As Worksheet
Dim vDB, vR()
Dim k As Long
Dim x As Long, y As Long


Set Ws = Sheets("Temp1")
Set toWs = Sheets(NameOfWorkbook)

Set c = CreateObject("Scripting.Dictionary") 'shops
Set r = CreateObject("Scripting.Dictionary") 'fruit

vDB = Ws.Range("a1").CurrentRegion
'*** These are 301 because you have already used variables in the loop. Therefore, you must start with zero.
k = 0 '<~ reset value k  because you use k and j k  (k, j value 301 )
j = 0 '<~ reset value j
For i = 2 To UBound(vDB, 1) 'if have header in sheet temp1 then i start with 2
    If Not c.Exists(vDB(i, 1)) Then
        k = k + 1
        c.Add vDB(i, 1), k  'Shop
    End If
    If Not r.Exists(vDB(i, 2)) Then
        j = j + 1
        r.Add vDB(i, 2), j  'Fruit
    End If
Next i
ReDim vR(1 To j, 1 To k)
For i = 2 To UBound(vDB, 1) 'if have header in sheet temp1 then i start with 2
    x = c.Item(vDB(i, 1))
    y = r.Item(vDB(i, 2))
    vR(y, x) = vR(y, x) + vDB(i, 3)
Next i

With toWs
    .Range("a1").CurrentRegion.Clear
    .Range("a2").Resize(j, 1) = WorksheetFunction.Transpose(r.Keys)
    .Range("b1").Resize(1, k) = c.Keys
    .Range("b2").Resize(j, k) = vR
End With

Весь код 

Sub Import()

    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim NameOfWorkbook As String
    Dim arr As Variant

    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Sheets.Add(After:=ActiveSheet).Name = "Temp1"
    Sheets.Add(After:=ActiveSheet).Name = "Temp2"
    Sheets.Add(After:=ActiveSheet).Name = "Stock at " & Format(Now, "DD-MM-YY HH-MM")
    NameOfWorkbook = ActiveSheet.Name

    'Step 1 open the Warehouse 1 book to import the data into NameOfWorkbook

        FileToOpen = Application.GetOpenFilename(Title:="Select Warehouse 1 stock report in csv format")
            If FileToOpen <> False Then
            Set OpenBook = Application.Workbooks.Open(FileToOpen)
            OpenBook.Sheets(1).Columns(3).Copy Destination:=ThisWorkbook.Sheets(NameOfWorkbook).Columns(1)
            OpenBook.Sheets(1).Columns(4).Copy Destination:=ThisWorkbook.Sheets(NameOfWorkbook).Columns(2)
            OpenBook.Sheets(1).Columns(7).Copy Destination:=ThisWorkbook.Sheets(NameOfWorkbook).Columns(3)
            ThisWorkbook.Sheets(NameOfWorkbook).Range("C1").Value = "Warehouse 1 Stock Available"
            OpenBook.Close False
            End If

    'Step 2 open the St.Neots book to import the data into NameOfWorkbook

        FileToOpen = Application.GetOpenFilename(Title:="Select Warehouse 2 stock report in csv format")
            If FileToOpen <> False Then
            Set OpenBook = Application.Workbooks.Open(FileToOpen)
            OpenBook.Sheets(1).Columns(7).Copy Destination:=ThisWorkbook.Sheets(NameOfWorkbook).Columns(4)
            ThisWorkbook.Sheets(NameOfWorkbook).Range("D1").Value = "Warehouse 2 Yard Stock Available"
            OpenBook.Close False
            End If

        Sheets(NameOfWorkbook).Columns("A:D").sort key1:=Range("B2"), _
              order1:=xlAscending, Header:=xlYes

    'Step 3 open the stock book to import the data into Temp1

        FileToOpen = Application.GetOpenFilename(Title:="Select Current Hires report in csv format")
            If FileToOpen <> False Then
            Set OpenBook = Application.Workbooks.Open(FileToOpen)
            arr = OpenBook.Sheets(1).Range("A1").CurrentRegion
            rowCount = UBound(arr, 1)
            columnCount = UBound(arr, 2)
            ThisWorkbook.Sheets("Temp1").Range("A1").Resize(rowCount, columnCount).Value = arr
            OpenBook.Close False
            End If

    'Step 4 join Site number with item for join stock from different days
        Dim st, et
        st = Timer

        Dim arr2 As Variant
        Dim i As Long, SiteName As Variant

        arr2 = ThisWorkbook.Sheets("Temp1").Range("A1").CurrentRegion
            For i = LBound(arr2) To UBound(arr2)
            SiteName = Split(arr2(i, 2), " - ")
            arr2(i, 1) = SiteName(UBound(SiteName)) & " && " & ThisWorkbook.Sheets("Temp1").Cells(i, 4).Value
            arr2(i, 2) = ThisWorkbook.Sheets("Temp1").Cells(i, 7).Value
            Next i

        rowCount = UBound(arr2, 1)
        columnCount = UBound(arr2, 2)
        ThisWorkbook.Sheets("Temp1").Range("A1").Resize(rowCount, columnCount).Value = arr2
        ThisWorkbook.Sheets("Temp1").Columns("c:M").EntireColumn.Delete

    'Step 5 join stock from same site sent different days

        Dim WorkRng As Range
        Dim Dic As Variant
        On Error Resume Next
        Set WorkRng = Range("A2:B5000")
        Set Dic = CreateObject("Scripting.Dictionary")
        arr = WorkRng.Value
        For i = 1 To UBound(arr, 1)
            Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 2)
        Next
        WorkRng.ClearContents
        WorkRng.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.transpose(Dic.Keys)
        WorkRng.Range("B1").Resize(Dic.Count, 1) = Application.WorksheetFunction.transpose(Dic.items)



    'Step 6 Separate site and material
        Dim arr3() As Variant
        Set WorkRng = ThisWorkbook.Sheets("temp1").Range("A1").CurrentRegion
        arr3 = WorkRng
        ReDim Preserve arr3(1 To UBound(arr3, 1), 1 To 3)
        For i = 2 To UBound(arr3, 1)
            'ThisWorkbook.Sheets("Temp1").Cells(i, 3) = ThisWorkbook.Sheets("Temp1").Cells(i, 2)
            'result = Split(ThisWorkbook.Sheets("Temp1").Cells(i, 1), " && ")
            'ThisWorkbook.Sheets("Temp1").Cells(i, 1) = RESULT(0)
            'ThisWorkbook.Sheets("Temp1").Cells(i, 2) = RESULT(1)
            arr3(i, 3) = arr3(i, 2)
            result = Split(arr3(i, 1), " && ")
            arr3(i, 1) = result(0)
            arr3(i, 2) = result(1)
        Next
        WorkRng.Range("a1").Resize(UBound(arr3, 1), 3) = arr3

    'Step 7 replace item code with name

    '    arr4 = ThisWorkbook.Sheets("temp1").Range("A1").CurrentRegion
    '    For i = 2 To UBound(arr4, 1)
    '        For j = 2 To 300
    '            If Worksheets("Temp1").Cells(i, 2) = Worksheets(NameOfWorkbook).Cells(j, 1) Then
    '                Worksheets("Temp1").Cells(i, 2) = Worksheets(NameOfWorkbook).Cells(j, 2)
    '                End If
    '        Next j
    '    Next i

        arr4 = Worksheets(NameOfWorkbook).Range("a1").CurrentRegion
        Dim d As Object
        Set d = CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(arr4, 1)
            If Not d.Exists(arr4(i, 1)) Then
                d.Add arr4(i, 1), arr4(i, 2)
            End If

        Next i
        For i = 2 To UBound(arr3, 1)
            arr3(i, 2) = d.Item(arr3(i, 2))
        Next i
        WorkRng = arr3
        'ThisWorkbook.Sheets(NameOfWorkbook).Columns("A:A").EntireColumn.Delete

    'Step 8 copy and order stock

        'Sheets("temp2").Range("a1:a5000").Value = Sheets("Temp1").Range("a1:a5000").Value
        'Sheets("temp2").Columns(1).RemoveDuplicates Columns:=Array(1)
        'ThisWorkbook.Sheets("Temp2").Columns("A:A").sort key1:=ThisWorkbook.Sheets("Temp2").Range("A2"), order1:=xlAscending, Header:=xlYes



        'For i = 5 To 100
        '    Sheets(NameOfWorkbook).Cells(1, i).Value = Sheets("temp2").Cells(i, 1).Value
        'Next

    '    Sheets(NameOfWorkbook).Rows(1).Orientation = 90
    '    Worksheets(NameOfWorkbook).Columns().columnwidth = 3
    '    Worksheets(NameOfWorkbook).Columns("B").columnwidth = 50
    '    Worksheets(NameOfWorkbook).Columns("C").columnwidth = 6
    '    Worksheets(NameOfWorkbook).Columns("D").columnwidth = 6
    '    Worksheets(NameOfWorkbook).Columns("A").Delete
    '    'Worksheets(NameOfWorkbook).Columns("A").Hidden = True

        'Step 9 populate the main sheet

        'For i = 1 To 1500
        '    For j = 1 To 150
        '       For k = 1 To 300
        '       If Worksheets("Temp1").Cells(i, 1) = Worksheets(NameOfWorkbook).Cells(1, j) And Worksheets("Temp1").Cells(i, 2) = Worksheets(NameOfWorkbook).Cells(k, 1) Then
        '            Worksheets(NameOfWorkbook).Cells(k, j) = Worksheets("Temp1").Cells(i, 3)
        '            End If
        '       Next k
        '    Next j
        'Next i


        Dim c As Object ' Dictionary
        Dim r As Object ' Dictionary
        Dim Ws As Worksheet
        Dim toWs As Worksheet
        Dim vDB, vR()
        Dim k As Long
        Dim x As Long, y As Long


        Set Ws = Sheets("Temp1")
        Set toWs = Sheets(NameOfWorkbook)

        Set c = CreateObject("Scripting.Dictionary") 'shops
        Set r = CreateObject("Scripting.Dictionary") 'fruit

        vDB = Ws.Range("a1").CurrentRegion

        k = 0
        j = 0
        For i = 2 To UBound(vDB, 1) 'if have header in sheet temp1 then i start with 2
            If Not c.Exists(vDB(i, 1)) Then
                k = k + 1
                c.Add vDB(i, 1), k  'Shop
            End If
            If Not r.Exists(vDB(i, 2)) Then
                j = j + 1
                r.Add vDB(i, 2), j  'Fruit
            End If
        Next i
        ReDim vR(1 To j, 1 To k)
        For i = 2 To UBound(vDB, 1) 'if have header in sheet temp1 then i start with 2
            x = c.Item(vDB(i, 1))
            y = r.Item(vDB(i, 2))
            vR(y, x) = vR(y, x) + vDB(i, 3)
        Next i

        With toWs
            .Range("a1").CurrentRegion.Clear
            .Range("a2").Resize(j, 1) = WorksheetFunction.transpose(r.Keys)
            .Range("b1").Resize(1, k) = c.Keys
            .Range("b2").Resize(j, k) = vR
            .Columns.AutoFit
            .Rows(1).Orientation = 90
            .Rows(1).HorizontalAlignment = xlCenter
            .Columns.ColumnWidth = 5
            .Columns("a").ColumnWidth = 50
            .Cells.Font.Size = 9
        End With
        et = Timer
        Debug.Print (et - st)
    'Step 10 delete auxiliar sheets

    'ThisWorkbook.Sheets("Temp1").Delete
    'ThisWorkbook.Sheets("Temp2").Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
End Sub

Изображение результата

enter image description here

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

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

...