Excel VBA优化 – 转置数据
我已经在Excel中以卷起的方式接收了一个报告，我需要将其导出到Access中。 以下是该行的示例：
客户帐户和姓名需要转换为与“凭证”行相邻，需要复制，因此每个凭证行都具有此信息。 转换之后，数据应该是这样的：
Customer Account | Name | Date | Voucher | Invoice | Transation Text | Currency 请注意，以“USD”开头的行表示该客户的logging结束。
我已经成功实现了以下代码：
Sub Process_Transactions() 'turn off some Excel functionality so code runs faster Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.DisplayStatusBar = False Application.EnableEvents = False Dim i As Long For i = 1 To 731055 'Move two columns in ActiveCell.Offset(0, 2).Select 'Select the customer account and name Range(ActiveCell, ActiveCell.Offset(1, 1)).Select 'Copy and paste it down two rows and over two columns Selection.Cut ActiveCell.Offset(2, -2).Select ActiveSheet.Paste 'Hop up a couple rows and delete 3 rows before the data that are not useful Rows(ActiveCell.Offset(-2).Row).Select Selection.Delete Shift:=xlUp Selection.Delete Shift:=xlUp Selection.Delete Shift:=xlUp 'Select the next row Rows(ActiveCell.Offset(1).Row).Select 'If the first record in the row is not "USD", then we have multiple rows for 'this customer While (ActiveCell.Offset(0, 2) <> "USD") 'Copy and Paste the customer account and number for each 'transaction row ActiveCell.Select Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, 1)).Select Selection.Copy ActiveCell.Offset(1, 0).Select ActiveSheet.Paste ActiveCell.Select ActiveCell.Offset(1, 0).Select Wend 'Delete the two rows after the data that we need ActiveCell.Select Rows(ActiveCell.Row).Select Selection.Delete Shift:=xlUp ActiveCell.Select Rows(ActiveCell.Row).Select Selection.Delete Shift:=xlUp 'Move to the next row to start over ActiveCell.Select Debug.Print "Current Row: " & i Next i 'at the end, don't forget to restore the default behavior 'calculate the formulas Application.Calculate Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayStatusBar = True Application.EnableEvents = True End Sub
问题是这个程序很慢。 我让代码运行了大约10个小时，昨天晚上，它只处理了33k。 我有大约150万个logging要处理。
我意识到，我正在使用的技术实际上正在移动活动的细胞，所以删除可能会有所帮助。 但是，我不确定如何继续。 如果这是一个失败的原因，更适合.net的实施，随时build议。
要做到这一点的快速方法是将大块数据抓取到一个二维变体数组中
Dim varr as Variant varr=Worksheets("Sheet1").Range("C5:G10005")
然后在数组上循环，然后创build另一个变体二维数组（varr2），然后将变体数组写入另一个工作表：
Worksheets("Sheet2").Range("A2:G2")=varr2
你的代码是挤满了非常低效的Excel-VBA方法！ 我会拍几张照片：
不要使用Selection.和Selection. 。 这太慢了。
为什么这样做
Range(ActiveCell, ActiveCell.Offset(1, 1)).Select Selection.Cut
当你可以做到这一点
Range(ActiveCell, ActiveCell.Offset(1, 1)).Cut
也不要使用ActiveCell来移动您的工作表。 只需要直接在你需要的任何单元或行上进行操作，例如
Sheet1.Cells(i,2).Copy Sheet1.Cells(i,1).Paste
其实，完全避免复制/粘贴，只是说
Sheet1.Cells(i,1).Value = Sheet1.Cells(i,2).Value
避免多次引用同一个对象，并使用With代替。 在这里， Sheet1被使用了两次，所以你可以这样写：
With Sheet1 .Cells(i,1).Value = .Cells(i,2).Value End With
以上只是一些例子，你将不得不适应你的情况，还有更多需要优化的地方，但他们会让你开始。 一旦清理完毕，请告诉我们你的代码，更多的build议会来！
您不必在每个执行的命令上select一个单元格。
这里是一个尝试：
Dim i As Long 'Suppose you want to start on cell A1 With ActiveSheet For i = 1 To 731055 'Move two columns to the right and select the customer account and name '.Range("C" & i & ":D" & i + 1).Cut 'Cut and paste it down two rows and over two columns '.Range("A" & i + 2 & ":B" & i + 3).Paste .Range("A" & i + 2 & ":B" & i + 3).Value = .Range("C" & i & ":D" & i + 1).Value 'Hop up a couple rows and delete 3 rows before the data that are not useful .Range("A" & i & ":C" & i + 2).EntireRow.Delete 'If the first record in the row is not "USD", then we have multiple rows for 'this customer While (.Range("C" & i + 1).Value <> "USD") 'Copy and Paste the customer account and number for each 'transaction row '.Range("A" & i & ":B" & i).Copy '.Range("A" & i + 1 & ":B" & i + 1).Paste .Range("A" & i + 1 & ":B" & i + 1).Value = .Range("A" & i & ":B" & i).Value i = i + 1 Wend 'Delete the two rows after the data that we need .Range("A" & i + 1 & ":A" & i + 2).EntireRow.Delete 'Move to the next row to start over Debug.Print "Current Row: " & i Next i End With
我改变了一点点我的代码复制只有值（这将快得多），而不是复制/粘贴>>看看你是否真的需要复制粘贴，以保持格式
尼克：有几个数字只是一点点，所以我已经更新了答案，以反映这些。
我也在Twitter上发布了这个post，并从@VisBasApp获得了以下内容：
Sub Process_TransactionsPAT() Const COL_CUSTOMER_ACC As Long = 3 Const COL_CUSTOMER_NAME As Long = 4 Const COL_CUSTOMER_VOUCHER As Long = 4 Const COL_CUSTOMER_INVOICE As Long = 5 Const COL_CUSTOMER_TRANS As Long = 6 Const COL_CUSTOMER_CURR As Long = 7 Const COL_CUSTOMER_AMT_CUR As Long = 8 Const COL_CUSTOMER_BAL_CUR As Long = 9 Const COL_CUSTOMER_BAL As Long = 10 Const COL_CUSTOMER_DUE_DATE As Long = 11 Const COL_CUSTOMER_COL_CODE As Long = 12 Const TEXT_TO_CHECK As String = "Customer account" Dim accNumber As Variant Dim accName As String Dim index As Long Dim counter As Long Dim originalData As Variant Dim transferedData() As Variant 'turn off some Excel functionality so code runs faster Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.DisplayStatusBar = False Application.EnableEvents = False originalData = Range("A1:L720909") counter = 0 For i = 1 To UBound(originalData, 1) If originalData(i, COL_CUSTOMER_ACC) = TEXT_TO_CHECK Then ' go to the first row under the text 'Customer Account' index = i + 1 ' get name and account number accNumber = originalData(index, COL_CUSTOMER_ACC) accName = originalData(index, COL_CUSTOMER_NAME) ' go to the first row under the text 'Date' index = index + 2 counter = counter + 1 While (UCase(originalData(index, COL_CUSTOMER_ACC)) <> "USD") ReDim Preserve transferedData(1 To 12, 1 To counter) transferedData(1, counter) = accNumber transferedData(2, counter) = accName transferedData(3, counter) = originalData(index, COL_CUSTOMER_ACC) transferedData(4, counter) = originalData(index, COL_CUSTOMER_VOUCHER) transferedData(5, counter) = originalData(index, COL_CUSTOMER_INVOICE) transferedData(6, counter) = originalData(index, COL_CUSTOMER_TRANS) transferedData(7, counter) = originalData(index, COL_CUSTOMER_CURR) transferedData(8, counter) = originalData(index, COL_CUSTOMER_AMT_CUR) transferedData(9, counter) = originalData(index, COL_CUSTOMER_BAL_CUR) transferedData(10, counter) = originalData(index, COL_CUSTOMER_BAL) transferedData(11, counter) = originalData(index, COL_CUSTOMER_DUE_DATE) transferedData(12, counter) = originalData(index, COL_CUSTOMER_COL_CODE) index = index + 1 counter = counter + 1 Wend ' it is not the best technique but for now it works i = index + 1 counter = counter - 1 End If Next i ' add data on a new sheet Sheets.Add Cells(1, 1) = "Customer Account" Cells(1, 2) = "Name" Cells(1, 3) = "Date" Cells(1, 4) = "Voucher" Cells(1, 5) = "Invoice" Cells(1, 6) = "Transaction Left" Cells(1, 7) = "Currency" Cells(1, 8) = "Amount in currency" Cells(1, 9) = "Balance in currency" Cells(1, 10) = "Balance" Cells(1, 11) = "Due Date" Cells(1, 12) = "Collection letter code" For i = 1 To UBound(transferedData, 2) For j = 1 To UBound(transferedData, 1) Cells(i + 1, j) = transferedData(j, i) Next j Next i Columns.AutoFit 'at the end, don't forget to restore the default behavior 'calculate the formulas Application.Calculate Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayStatusBar = True Application.EnableEvents = True End Sub
这需要大约2分钟来parsing750,000条logging。
我会把数据原样扔到数据库上，然后写一个查询来做到这一点。 当我回家时，我会写一个查询和更新答案（我在我的手机上，它不可能写入SQL 🙂