Değiştir Excel VBA kodu çalışması için daha hızlı

Question

Daha sonra 100k satır içeren bir dosya var, ancak yapı basittir:

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

Sonucu gereken "Jan" den "Aralık" dan olmak oniki aynı oluşturulur tablolar "Name-Position-Colour" sütun sayfasından1, "Name-slice" -column ve "Position-slice" -head satırı olarak sayfa 3'e yerleştirilir. "Renk" parçasına artık gerek yok. Tablolar, ilk listede konumlandıkları bir süre dahil olmak üzere "Position-slice" ile çarpılarak "Name-slice" ile doldurulmalıdır. Umarım bunu anlayabilecek kadar bilgilendirici olur. Bu yüzden, bir makro yazmayı başardım (sadece birkaç satır aşağıda bulunur), ancak listede sadece 228 satır olduğunda bile gerçekten çok yavaş çalışıyor. Bir hesaplama parçası eklemeden hemen önce hızlı bir şekilde çalıştı. Nesne programlamanın biraz zaman kazanabileceğini düşünüyorum, ama henüz öğrenmedim. Birisi benim kodumu geliştirmenin yolunu bana söyleyebilirse çok memnun olurum, bu yüzden daha hızlı çalışır. Herhangi bir tavsiye de çok yararlı olurdu ... Teşekkürler. Aşağıdaki kodun tamamını görebilirsiniz.

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 

Answer 1

Sadece küçük bir fikir - kodunuzun zamanının çoğunu nerede aldığını anlamak için 4-5 yerde aşağıdaki kodu yazın. Ardından geliştirmeniz gereken yeri göreceksiniz. Sonra tekrar sadece bu yer paylaşabilir veya muhtemelen (

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