优化宏以组织数据 [英] Optimizing macro for organizing data

问题描述

我已经从一个要组织的数据库中导出了一些csv，我在excel中制作了一个VBA宏，大约需要40分钟才能完成，我想知道如何对其进行优化(主要是学习)

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).

想象一下，您有不同的水果店出售不同的水果，而您得到的csv就像:

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

Worksheets("Temp1")=

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)=

Worksheets(NameOfWorkbook) =

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

我想要一个宏来填充最后一张工作表，例如:

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

Worksheets(NameOfWorkbook)=

Worksheets(NameOfWorkbook) =

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

所以我使用的宏是一个三重for循环:

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 so much for your comments and answers, much appreciated.

我确实想过透视表，但是，我不确定如何将其应用到我的问题中，因为其中一列(Shops)可能需要旋转，但是带有值的列会分散填充工作表，并且不能保持为单一列.

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:

工作流程为:

第0步: 禁用可能会降低性能的应用程序，创建2no临时工作表"Temp1"和"Temp2"来组织信息，并创建一个工作表，在其中将显示所有信息并将其命名为实际日期和时间.

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.

第1步: 打开仓库1报告.csv并导入数据，因为并非所有列都需要导入

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

第2步: 打开仓库2报告.csv并导入数据，因为并非所有列都需要导入

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

第3步: 打开报表.csv并将数据导入"Temp1"

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

第4步: 由于重复了一些数据(例如:我在第1天从商店1卖出3个苹果，在第5天从商店1卖出4个苹果)，因此我将Shop1&&苹果删除重复项并添加Shop1&&的值苹果总共7个，然后将Shop1和Apple分成不同的列

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

第5步: 加入股票因为日期并不重要，但总价值

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

第6步: 分割商店和水果的价值

Step 6: Split the shop and fruit values

第7步: 报表中的值不是要显示的值，因此我从仓库的导入列中替换了它(例如:在report.csv中，"apples"显示为"AP"，"Mango"显示为"MG")

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")

步骤8: 商店的名称已复制到工作表"Temp2"中，此代码是在将它们复制到最终工作表的column1中之前，按字母顺序对其进行组织，此外，我还更改了列的宽度和方向以便于阅读

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

第9步: 填充代码，我从Dy.Lee替换了我的代码，运行时间减少了40分钟，不到30秒(老实说，我很感激，非常感谢，谢谢，非常感谢)

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)

第10步: 删除辅助工作表并重新激活应用程序

Step 10: Delete auxiliary sheets and re-activate applications

但是，在使用DY.Lee代码后，填充代码的值从303行及以下显示，与他们的商店和水果(?)不匹配

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
'

请找到文件:

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

推荐答案

有多种使用数据透视表，sql语句和最后一个字典的方法. 我使用了字典方法.

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

已编辑

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

结果图片

这篇关于优化宏以组织数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！