如何加快这个VBA代码？

excel文件有9张。 每张纸有1668行和34个供应商。 我想创build一个包含所有数据的表单。 我知道这样会有重复，但现在并不重要。 有没有办法加快代码？ 它需要永恒的时间来复制大约510.000条logging。 （当我尝试用for循环的时候，你可以看到我的第一次尝试的意见，这不是一个好主意。）

Sub goEasy() Dim wsText As Variant Dim sht As Worksheet Dim wSum As Worksheet Dim service As String Dim supplier As String Dim priceRange As String Dim price As String Dim Lrow As Long, LastRow As Long Dim a As Long, b As Long Set sht = ThisWorkbook.Worksheets(4) Set wSum = ThisWorkbook.Worksheets("Summary") wsText = Array("<25K", "25K <100K", "100K <250K", "250K <500K", "500K <1M", "1M <5M", "5M <15M", "15M <30M", "30M <50M") LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row For Each element In wsText 'For i = 5 To LastRow a = 4 b = 12 Do While a < LastRow 'For j = 13 To 47 If a = LastRow Then a = 4 Exit Do End If a = a + 1 Do While b <= 47 If b = 47 Then b = 12 Exit Do End If b = b + 1 Lrow = wSum.UsedRange.Rows(wSum.UsedRange.Rows.Count).Row + 1 service = ThisWorkbook.Worksheets(element).Cells(a, 1).Text supplier = ThisWorkbook.Worksheets(element).Cells(4, b).Text priceRange = ThisWorkbook.Worksheets(element).Cells(2, 1).Text price = ThisWorkbook.Worksheets(element).Cells(a, b).Text wSum.Cells(Lrow, 1) = service wSum.Cells(Lrow, 2) = supplier wSum.Cells(Lrow, 3) = priceRange wSum.Cells(Lrow, 4) = price 'Next j Loop 'Next i Loop Next element End Sub 

Answer 1

请尝试下面的代码。 （未testing）
它花费时间将价值写入单元格。 保持写入单元格的值会让你的VBA变慢。
通过数组，你只能写入单元格一次。 这将节省很多时间。

 Sub goEasy() dim a as long, b as long, LastRow as long dim sht as worksheet, wSum as worksheet dim wsText as variant, element as variant, dAry as variant set sht = thisworkbook.worksheets(4) set wSum = Thisworkbook.worksheets("summary") wsText = Array("<25K", "25K <100K", "100K <250K", "250K <500K", "500K <1M", "1M <5M", "5M <15M", "15M <30M", "30M <50M") LastRow = sht.Cells(Rows.Count, 1).End(xlUp).Row For Each element In wsText a = 5 b = 13 Do until a > LastRow 'For i = 5 To LastRow Do until b > 47 'For j = 13 To 47 if not isarray(dAry) then redim dAry(3, 0) as variant else redim preserve dAry(3, ubound(dAry, 2) + 1) as variant end if With thisworkbook.Worksheets(element) dAry(0, ubound(dAry,2)) = .Cells(a, 1).Text dAry(1, ubound(dAry,2)) = .Cells(4, b).Text dAry(2, ubound(dAry,2)) = .Cells(2, 1).Text dAry(3, ubound(dAry,2)) = .Cells(a, b).Text End With b = b + 1 'Next j Loop b = 13 a = a + 1 'Next i Loop Next element wSum.Cells(rows.count, 1).end(xlup).offset(1).resize(ubound(dAry,2) + 1, ubound(dAry,1) + 1) = application.transpose(dAry) End Sub 

Answer 2

这应该做到这一点：

 Sub goEasy() Dim wsText As Variant Dim sht As Worksheet Dim wSum As Worksheet Dim service As String Dim supplier As String Dim priceRange As String Dim price As String Dim Lrow As Long, LastRow As Long Dim a As Long, b As Long Application.ScreenUpdating = False Set sht = ThisWorkbook.Worksheets(4) Set wSum = ThisWorkbook.Worksheets("Summary") wsText = Array("<25K", "25K <100K", "100K <250K", "250K <500K", "500K <1M", "1M <5M", "5M <15M", "15M <30M", "30M <50M") LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row For Each element In wsText 'For i = 5 To LastRow a = 4 b = 12 Do While a < LastRow 'For j = 13 To 47 If a = LastRow Then a = 4 Exit Do End If a = a + 1 Do While b <= 47 If b = 47 Then b = 12 Exit Do End If b = b + 1 Lrow = wSum.UsedRange.Rows(wSum.UsedRange.Rows.Count).Row + 1 service = ThisWorkbook.Worksheets(element).Cells(a, 1).Text supplier = ThisWorkbook.Worksheets(element).Cells(4, b).Text priceRange = ThisWorkbook.Worksheets(element).Cells(2, 1).Text price = ThisWorkbook.Worksheets(element).Cells(a, b).Text wSum.Cells(Lrow, 1) = service wSum.Cells(Lrow, 2) = supplier wSum.Cells(Lrow, 3) = priceRange wSum.Cells(Lrow, 4) = price 'Next j Loop 'Next i Loop Next element Application.ScreenUpdating = True End Sub