1. 技术文章
  2. Optimizing macro for organizing data

Optimizing macro for organizing data

由 拥有回忆 提交于 2020-06-26 14:11:27

问题


I've got some csv export from a Database that I want to organise, I've made a VBA macro in excel that takes around 40 min to finish and I would like to know how to optimise it (Mainly to learn).

Imagine that you got different fruit shops that sells different fruits and the csv you get is like:

Worksheets("Temp1")=

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

I've already created a sheet like:

Worksheets(NameOfWorkbook) =

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

And I want a macro that populate the last sheet like:

Worksheets(NameOfWorkbook) =

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

So the macro I use is a triple for loop as:

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

I would like to know away to optimize the code, any help would be much appreciated.

Thanks very much.

Kind Regards.

EDIT

Thanks so much for your comments and answers, much appreciated.

I did look about pivoting tables, however, I was not sure how to apply it into my problem, as one of the columns(Shops) may need to be pivoted, but the column with values will disperse populating the sheet and will not remain as a single column.

Please find below the full code:

the workflow is as:

Step 0: Disable applications that may slow the performance, create 2no of temporary sheets "Temp1" and "Temp2" to organise the info and create a sheet where all the information will be displayed naming it with actual date and time.

Step 1: Open warehouse 1 report .csv and import the data, as not all columns need to be imported

Step 2: Open warehouse 2 report .csv and import the data, as not all columns need to be imported

Step 3: Open report .csv and import the data into "Temp1"

Step 4: As some data is duplicated (Example: I sell 3 apples from shop 1 on day 1 and 4 apples from shop1 on day 5), i join the values of Shop1 && Apples to remove duplicates and add the values for Shop1 && Apples for a total of 7 and then split Shop1 and Apples in different columns

Step 5: Join the stock as the date is not important but the total value

Step 6: Split the shop and fruit values

Step 7: The value in the report is not the want to be displayed, so I replace it from the imported column from the warehouse (Example: in report.csv "apples" are displayed as "AP" and "Mango" as "MG")

Step 8: The name of shops was copied into sheet"Temp2" this code is to organise them alphabetically before copying them into column1 of the final sheet, also I change columns width and orientation for easy read

Step 9: The populating code, I substituted mine from Dy.Lee, the run time went down 40 min to less than 30 sec (I'm honestly impressed and gratefully, thanks, really thanks)

Step 10: Delete auxiliary sheets and re-activate applications

However, after using DY.Lee code, the values of the populating code are displayed from row 303 and below, not matching their shop and fruit (?)

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
'

Please find files:

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:


There are ways to use pivot table, sql statement, and last dictionary. I used a dictionary method.

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

Edited

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

Entire Code

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

Result image



来源：https://stackoverflow.com/questions/60470124/optimizing-macro-for-organizing-data

标签
excel
vba
optimization
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!