修改Excel VBA代码以使其工作更快

我有一个超过10万行的文件，但结构很简单：

Date       | Name-Position-Color | Summ
17.11.2015 |"Name1               | 8813,52
           | Position1           |
          _|_Color1"            _|_
19.08.2015 |"Name2               | 3587,86
           | Position3           |
          _|_Color5"            _|_
12.01.2015 |"Name3               | 14,63
           | Position16          |
          _|_Color7"            _|_
07.12.2015 |"Name4               | 7129,97
           | Position11          |
           | Color3"             |

结果应该是从“名称-位置-颜色”列sheet1中的“Jan”到“Dec”的十二个格式相同的表格，作为“名称-切片”-列和“位置-切片”-首行放置在sheet3中。“颜色”部分不再需要。表格应该用“名称切片”乘以“位置切片”来填充，包括它们在第一个列表中定位的时间段。我希望这是足够的信息，以理解。因此，我成功地编写了一个宏（它位于下面几行），但它的运行速度非常慢，即使我在列表中只有228行。在我添加计算部分之前，它运行得很快。我认为对象编程可以节省一些时间，但我还没有学会。如果有人能告诉我改进代码的方法，我会非常感激，这样它会工作得更快。任何建议都会非常有用。。。谢谢您可以在下面看到整个代码

Sub tablesByMonths()

'def column in sheet1
colNum1 = 2
'def column in sheet3
colNum3 = 2 '2 is minimal for correct macro work
'def last row in sheet1
lastRow1 = Worksheets("Sheet1").Cells(Rows.Count, colNum1).End(xlUp).Row
'def first row in sheet1
firstRow1 = Worksheets("Sheet1").Cells(Rows.Count,     colNum1).End(xlUp).End(xlUp).Row + 1
'def last row in sheet3
step = 2

Application.ScreenUpdating = False                  'turns off dynamic screen update
Application.Calculation = xlCalculationManual       'turns off automatic formulas

'clears all used range in a sheet3
Worksheets("Sheet3").UsedRange.Clear

'this counts months from Jan to Dec
For per = 1 To 12

'def last row in sheet3
lastRow3_1 = Worksheets("Sheet3").Cells(Rows.Count, colNum3).End(xlUp).Row
'puts current number from per loop and adds "/01/2015"
Worksheets("Sheet3").Cells(lastRow3_1 + step, colNum3 - 1).Value = per & "/01/2015"
'converts date into month format
Worksheets("Sheet3").Cells(lastRow3_1 + step, colNum3 - 1).NumberFormat = "mmmm"

'loop through the entire list in a sheet1 column colNum1
For x = firstRow1 To lastRow1

    'def current cell value
    curVal1 = Worksheets("Sheet1").Cells(x, colNum1)
    'def first space position in curVal1
    spacePos1 = InStr(1, curVal1, Chr(10), vbBinaryCompare)
    'def second space position in curVal1
    spacePos2 = InStr(spacePos1 + 1, curVal1, Chr(10), vbBinaryCompare)
    'def first word in curVal1 cell and place it into sheet3
    Worksheets("Sheet3").Cells(lastRow3_1 + step - 1 + x, colNum3) = Mid(curVal1, 1, spacePos1 - 1)
    'def second word in curVal1 cell and place it into sheet3
    Worksheets("Sheet3").Cells(lastRow3_1 + step - 2 + x, colNum3 + 1) = Mid(curVal1, spacePos1 + 1, spacePos2 - spacePos1 - 1)

Next x

'def last row in a new list sheet3
lastRow3 = Worksheets("Sheet3").Cells(Rows.Count, colNum3).End(xlUp).Row
'def last row in a new list sheet3
firstRow3 = Worksheets("Sheet3").Cells(Rows.Count, colNum3).End(xlUp).End(xlUp).Row

'del replicas from list with names and sort in ascend order in sheet3
With Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3, colNum3), Worksheets("Sheet3").Cells(lastRow3, colNum3))

    .RemoveDuplicates Columns:=Array(1), Header:=xlNo
    .Sort key1:=Worksheets("Sheet3").Cells(firstRow3, colNum3), Header:=xlNo

End With

'del replicas from list with positions and sort in ascend order in sheet3
With Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3 - 1, colNum3 + 1), Worksheets("Sheet3").Cells(lastRow3, colNum3 + 1))

    .RemoveDuplicates Columns:=Array(1), Header:=xlNo
    .Sort key1:=Worksheets("Sheet3").Cells(firstRow3 - 1, colNum3 + 1), Header:=xlNo

End With

'def new last cell for list of positions in sheet3
lastRow3_2 = Worksheets("Sheet3").Cells(Rows.Count, colNum3 + 1).End(xlUp).Row

'transpose sorted list of items into head row
Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3 - 1, colNum3 + 1), Worksheets("Sheet3").Cells(firstRow3 - 1, lastRow3_2 - firstRow3 + colNum3 + 1)) = Worksheets("Sheet3").Application.Transpose(Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3 - 1, colNum3 + 1), Worksheets("Sheet3").Cells(lastRow3_2, colNum3 + 1)))
Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(firstRow3, colNum3 + 1), Worksheets("Sheet3").Cells(lastRow3_2, colNum3 + 1)).Clear

'def last row in a new list sheet3 after deleting dublicates (need a method of calling a function to do it repeatedly)
lastRow3n = Worksheets("Sheet3").Cells(Rows.Count, colNum3).End(xlUp).Row
'loop through list of names
For namesList = firstRow3 To lastRow3n

    For headRow = colNum3 + 1 To lastRow3_2 - firstRow3 + colNum3 + 1

        'takes position name of the current position in the head row list
        currentValue = Worksheets("Sheet3").Cells(namesList, colNum3) & Chr(10) & Worksheets("Sheet3").Cells(firstRow3 - 1, headRow) & Chr(42)
        Worksheets("Sheet3").Cells(namesList, headRow).Value = "0.00"                'def starting value
        Worksheets("Sheet3").Cells(namesList, headRow).NumberFormat = "#,##0.00"     'establishes cell format
        'loop through list in the base table
        For firstList = firstRow1 To lastRow1

            listValue = Worksheets("Sheet1").Cells(firstList, colNum1).Value
            'checks if value in the first list equal to the current combined value
            If listValue Like currentValue Then

                Worksheets("Sheet3").Cells(namesList, headRow).Value = Worksheets("Sheet3").Cells(namesList, headRow).Value + Worksheets("Sheet1").Cells(firstList, colNum1 + 1).Value

            End If

        Next firstList

    Next headRow

Next namesList

Next per

Application.ScreenUpdating = True                   'turns on dynamic screen update
Application.Calculation = xlCalculationAutomatic    'turns on automatic formulas

End Sub

---

这只是一个小主意——为了理解你的代码在哪里花费了大部分时间，请在下面的4-5个地方写代码。 然后你会看到你应该改进的地方。 然后再分享一次，就在那个地方，或许你可以提高自己：）

---

这只是一个小主意——为了理解你的代码在哪里花费了大部分时间，请在下面的4-5个地方写代码。 然后你会看到你应该改进的地方。 然后再分享一次，就在那个地方，或许你可以提高自己：）

---

这个问题更适合StackOverflow，甚至可能与StackOverflow无关。我绝对推荐。虽然特定的速度优化可以是堆栈溢出的主题，但在这种情况下，您真正需要的不是速度调整，而是VBA最佳实践的全面指南。非常感谢。我不知道那个来源。这个问题更适合StackOverflow，甚至可能是离题的。我绝对推荐。虽然特定的速度优化可以是堆栈溢出的主题，但在这种情况下，您真正需要的不是速度调整，而是VBA最佳实践的全面指南。非常感谢。我不知道那个消息来源，谢谢！我一定会试试这个方法。谢谢！我一定要试试这个方法。

Debug.Print "TEST1 " & Now
Debug.Print "TEST2 " & Now