Question

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

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

结果应该是来自＆＃34; Jan＆＃34;的十二个相同形成的表格。到＆＃34; 12月＆＃34;切换自＆＃34;名称 - 位置 - 颜色＆＃34; column sheet1放入sheet3作为＆＃34; Name-slice＆＃34; -column和＆＃34; Position-slice＆＃34; - 行。＆＃34;颜色＆＃34;部分不再需要。表格应该用乘法＆＃34; Name-slice＆＃34;填充。通过＆＃34;位置切片＆＃34;包括他们在第一个列表中定位的时间段。我希望这足以让人理解。所以，我设法编写了一个宏（它位于下面的几行），但即使我在列表中只有228行，它仍然很慢。在我添加计算部分之前，它已经快速工作了。我认为对象编程可以节省一些时间，但我还没有学到它。如果有人能告诉我改进代码的方法，我会非常感激，因此它可以更快地完成工作。任何建议都会非常有用......谢谢。您可以在下面看到完整的代码。

<script>
/* yourfunction */
if(typeof yourfunction == 'function') {   
  yourfunction();   
}
function yourfunction(){
  //function code
}
</script>

Answer 1

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

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

修改Excel VBA代码以使其更快地运行

1 个答案: