修改Excel的VBA代码，使其运行速度更快

我有更多的则10万行的文件，但结构很简单：修改Excel的VBA代码，使其运行速度更快

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中作为“名称 - 切片” - 列和“位置 - 切片” - 行。 “颜色”部分不再需要。应该用“位置切片”乘以“名称切片”来填充表格，包括它们在第一个列表中的位置。我希望这是足够的信息来理解。所以，我设法编写了一个宏（它位于下面几行），但即使列表中只有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

来源

2016-03-29 Alex K

这个问题更适合[CodeReview.SE]（http://codereview.stackexchange.com/help/on-topic ），甚至可能会在StackOverflow上脱离主题。 – Vegard

我**绝对**推荐[codereview.se]。虽然具体的速度优化**可以成为Stack Overflow的On-Topic，但在这种情况下，您真正需要的不是速度调整，而是VBA最佳实践的全面指南。 – Kaz

非常感谢。我不知道这个消息来源。 –

只是一个小想法 - 为了了解代码占用大部分时间的地方，请在4-5位置写下面的代码。然后你会看到你应该改善的地方。然后再分享，刚才那地方，或者可能是你可以提高自己:)

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

来源

2016-03-29 12:26:32 Vityata

谢谢！我一定会尝试这种方法。 –

修改Excel的VBA代码，使其运行速度更快

回答

相关问题