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

我有一个文件有更多的100K行,但结构很简单:

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中放置到sheet3中的“Jan”到“Dec”的十二个同样形成的表格,作为“Name-Slice”列和“Position-slice”头行。 “颜色”部分不再需要。 应该用“位置切片”乘以“名称切片”来填充表格,包括它们在第一个列表中的位置。 我希望这是足够的信息来理解。 所以,我设法写了一个macros(它位于下面几行),但是即使在列表中只有228行时,它的运行速度也非常慢。 在我添加一个计算部分之前,它工作得很快。 我认为对象编程可以节省一些时间,但我还没有学到它。 如果有人能告诉我改进我的代码的方法,我会非常感激,所以它会更快。 任何build议也会很有帮助…谢谢。 你可以看到下面的整个代码。

 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个地方写下面的代码。 然后你会看到你应该改善的地方。 然后再分享,就是那个地方,或者你可以改善自己:)

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