VBA 需要代码效率建议
VBA Code Efficiency Advice Needed
对于非常大的 Excel csv 文件（可以大到 35MB+ & >100k 行），我的处理步骤之一是检查列 A 的 "record type" 指示器并根据值， cut/paste 行中不同位置的 2 个连续单元格，一直到行尾（第 51 和 52 列）。
以下代码通过了 'CompileVBAProject' 测试，但我 确定 有更高效、更快的脚本，我只是没有想到。是的，我是一个 VBA 半菜鸟，但我正在努力快速变得更好。有什么建议吗？
For i = 4 To rng.Rows.Count
If Cells(i, 1).Value = "10EE" Then
Range("AW" & i & ":AY" & i).Copy Cells(i, 50)
Range("AW" & i).ClearContents
Else
If Cells(i, 1).Value = "05EE" Then
Range("M" & i & ":N" & i).Copy Cells(i, 51)
Range("M" & i & ":N" & i).ClearContents
Else
If (Cells(i, 1).Value = "11EE" Or Cells(i, 1).Value = "25CP" Or Cells(i, 1).Value = "26EP" _
Or Cells(i, 1).Value = "51CL" Or Cells(i, 1).Value = "60PM") Then
Range("L" & i & ":M" & i).Copy Cells(i, 51)
Range("L" & i & ":M" & i).ClearContents
Else
If Cells(i, 1).Value = "15EM" Then
Range("M" & i & ":N" & i).Copy Cells(i, 51)
Range("M" & i & ":N" & i).ClearContents
Else
If Cells(i, 1).Value = "17EA" Then
Range("X" & i & ":Y" & i).Copy Cells(i, 51)
Range("X" & i & ":Y" & i).ClearContents
Else
If Cells(i, 1).Value = "20DP" Then
Range("AC" & i & ":AD" & i).Copy Cells(i, 51)
Range("AC" & i & ":AD" & i).ClearContents
Else
If Cells(i, 1).Value = "24AH" Then
Range("AD" & i & ":AE" & i).Copy Cells(i, 51)
Range("AD" & i & ":AE" & i).ClearContents
Else
If Cells(i, 1).Value = "30EL" Then
Range("V" & i & ":W" & i).Copy Cells(i, 51)
Range("V" & i & ":W" & i).ClearContents
Else
If Cells(i, 1).Value = "31EL" Then
Range("O" & i & ":P" & i).Copy Cells(i, 51)
Range("O" & i & ":P" & i).ClearContents
Else
If Cells(i, 1).Value = "40DE" Then
Range("R" & i & ":S" & i).Copy Cells(i, 51)
Range("R" & i & ":S" & i).ClearContents
Else
If Cells(i, 1).Value = "50CL" Then
Range("AB" & i & ":AC" & i).Copy Cells(i, 51)
Range("AB" & i & ":AC" & i).ClearContents
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next i
如果您使用的是 Set rng = Application.Range("A4:A" & lrow)，则 For i = 4 To rng.Rows.Count 不正确。
一个Select案例似乎很适合这个。我组合了“05EE”和“15EM”。
with worksheets(1)
For i = 4 To lrow
Select Case .Cells(i, 1).Value2
Case "10EE"
.Cells(i, "AX").Resize(1, 3) = .Cells(i, "AW").Resize(1, 3).Value2
.Cells(i, "AW").ClearContents
Case "05EE", "15EM"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "M").Resize(1, 2).Value2
.Cells(i, "M").Resize(1, 2).ClearContents
Case "11EE", "25CP", "26EP", "51CL", "60PM"
.Cells(i, "AY").Resize(1, 3) = .Cells(i, "L").Resize(1, 3).Value2
.Cells(i, "L").Resize(1, 3).ClearContents
Case "17EA"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "X").Resize(1, 2).Value2
.Cells(i, "X").Resize(1, 2).ClearContents
Case "20DP"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AC").Resize(1, 2).Value2
.Cells(i, "AC").Resize(1, 2).ClearContents
Case "24AH"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AD").Resize(1, 2).Value2
.Cells(i, "AD").Resize(1, 2).ClearContents
Case "30EL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "V").Resize(1, 2).Value2
.Cells(i, "V").Resize(1, 2).ClearContents
Case "31EL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "O").Resize(1, 2).Value2
.Cells(i, "O").Resize(1, 2).ClearContents
Case "40DE"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "R").Resize(1, 2).Value2
.Cells(i, "R").Resize(1, 2).ClearContents
Case "50CL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AB").Resize(1, 2).Value2
.Cells(i, "AB").Resize(1, 2).ClearContents
Case Else
'do nothing
End Select
Next i
end with
如果某些值出现的频率更高，它们应该位于 Case 条件的顶部。
另一种构造数据并使用数组的方法：
Option Explicit
Public Sub CopyVals()
Const START_ROW = 4
Dim ws As Worksheet, rng As Range, map As Variant, arr As Variant, mapUb As Long
Set ws = Sheet3 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
Set rng = ws.UsedRange
arr = rng 'Copy Range to Array
map = GetMapping(map) 'Get Mapping: Values to Columns
mapUb = UBound(map)
Dim r As Long, i As Long, j As Long
For r = START_ROW To rng.Rows.Count
For i = 1 To mapUb
If arr(r, 1) = map(i, 1) Then
For j = 0 To map(i, 4) 'map4 = Offset col
' map3 = copyTo col map2 = copyFrom col
arr(r, map(i, 3) + j) = arr(r, map(i, 2) + j)
Next
End If
Next
Next
rng.Offset(rng.Rows.Count + 1, 0) = arr
End Sub
Private Function GetMapping(ByRef map As Variant) As Variant
Const ITM = "10EE 05EE 11EE 25CP 26EP 51CL 60PM 15EM 17EA 20DP 24AH 30EL 31EL 40DE 50CL"
Const SRC = "49 13 12 12 12 12 12 13 24 29 30 22 15 18 28"
Const DST = "50 51 51 51 51 51 51 51 51 51 51 51 51 51 51"
Const OFF = "2 1 1 1 1 1 1 1 1 1 1 1 1 1 1" 'Total columns to copy From / To + 1
Dim v As Variant, s As Variant, d As Variant, o As Variant, i As Long
v = Split(ITM)
s = Split(SRC)
d = Split(DST)
o = Split(OFF)
ReDim map(1 To UBound(v) + 1, 1 To 4) As Variant
For i = 1 To UBound(v) + 1
map(i, 1) = v(i - 1) 'Values
map(i, 2) = s(i - 1) 'From First Col
map(i, 3) = d(i - 1) 'To First Col
map(i, 4) = o(i - 1) 'Total Cols (both From and To)
Next
GetMapping = map
End Function
.
Map Array returned by GetMapping()
Value From First Col To First Col Total Cols (+ 1)
map( 1, 1) = "10EE": map( 1, 2) = 49: map( 1, 3) = 50: map( 1, 4) = 2
map( 2, 1) = "05EE": map( 2, 2) = 13: map( 2, 3) = 51: map( 2, 4) = 1
map( 3, 1) = "11EE": map( 3, 2) = 12: map( 3, 3) = 51: map( 3, 4) = 1
map( 4, 1) = "25CP": map( 4, 2) = 12: map( 4, 3) = 51: map( 4, 4) = 1
map( 5, 1) = "26EP": map( 5, 2) = 12: map( 5, 3) = 51: map( 5, 4) = 1
map( 6, 1) = "51CL": map( 6, 2) = 12: map( 6, 3) = 51: map( 6, 4) = 1
map( 7, 1) = "60PM": map( 7, 2) = 12: map( 7, 3) = 51: map( 7, 4) = 1
map( 8, 1) = "15EM": map( 8, 2) = 13: map( 8, 3) = 51: map( 8, 4) = 1
map( 9, 1) = "17EA": map( 9, 2) = 24: map( 9, 3) = 51: map( 9, 4) = 1
map(10, 1) = "20DP": map(10, 2) = 29: map(10, 3) = 51: map(10, 4) = 1
map(11, 1) = "24AH": map(11, 2) = 30: map(11, 3) = 51: map(11, 4) = 1
map(12, 1) = "30EL": map(12, 2) = 22: map(12, 3) = 51: map(12, 4) = 1
map(13, 1) = "31EL": map(13, 2) = 15: map(13, 3) = 51: map(13, 4) = 1
map(14, 1) = "40DE": map(14, 2) = 18: map(14, 3) = 51: map(14, 4) = 1
map(15, 1) = "50CL": map(15, 2) = 28: map(15, 3) = 51: map(15, 4) = 1
对于非常大的 Excel csv 文件（可以大到 35MB+ & >100k 行），我的处理步骤之一是检查列 A 的 "record type" 指示器并根据值， cut/paste 行中不同位置的 2 个连续单元格，一直到行尾（第 51 和 52 列）。
以下代码通过了 'CompileVBAProject' 测试，但我 确定 有更高效、更快的脚本，我只是没有想到。是的，我是一个 VBA 半菜鸟，但我正在努力快速变得更好。有什么建议吗？
For i = 4 To rng.Rows.Count
If Cells(i, 1).Value = "10EE" Then
Range("AW" & i & ":AY" & i).Copy Cells(i, 50)
Range("AW" & i).ClearContents
Else
If Cells(i, 1).Value = "05EE" Then
Range("M" & i & ":N" & i).Copy Cells(i, 51)
Range("M" & i & ":N" & i).ClearContents
Else
If (Cells(i, 1).Value = "11EE" Or Cells(i, 1).Value = "25CP" Or Cells(i, 1).Value = "26EP" _
Or Cells(i, 1).Value = "51CL" Or Cells(i, 1).Value = "60PM") Then
Range("L" & i & ":M" & i).Copy Cells(i, 51)
Range("L" & i & ":M" & i).ClearContents
Else
If Cells(i, 1).Value = "15EM" Then
Range("M" & i & ":N" & i).Copy Cells(i, 51)
Range("M" & i & ":N" & i).ClearContents
Else
If Cells(i, 1).Value = "17EA" Then
Range("X" & i & ":Y" & i).Copy Cells(i, 51)
Range("X" & i & ":Y" & i).ClearContents
Else
If Cells(i, 1).Value = "20DP" Then
Range("AC" & i & ":AD" & i).Copy Cells(i, 51)
Range("AC" & i & ":AD" & i).ClearContents
Else
If Cells(i, 1).Value = "24AH" Then
Range("AD" & i & ":AE" & i).Copy Cells(i, 51)
Range("AD" & i & ":AE" & i).ClearContents
Else
If Cells(i, 1).Value = "30EL" Then
Range("V" & i & ":W" & i).Copy Cells(i, 51)
Range("V" & i & ":W" & i).ClearContents
Else
If Cells(i, 1).Value = "31EL" Then
Range("O" & i & ":P" & i).Copy Cells(i, 51)
Range("O" & i & ":P" & i).ClearContents
Else
If Cells(i, 1).Value = "40DE" Then
Range("R" & i & ":S" & i).Copy Cells(i, 51)
Range("R" & i & ":S" & i).ClearContents
Else
If Cells(i, 1).Value = "50CL" Then
Range("AB" & i & ":AC" & i).Copy Cells(i, 51)
Range("AB" & i & ":AC" & i).ClearContents
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next i
如果您使用的是 Set rng = Application.Range("A4:A" & lrow)，则 For i = 4 To rng.Rows.Count 不正确。
一个Select案例似乎很适合这个。我组合了“05EE”和“15EM”。
with worksheets(1)
For i = 4 To lrow
Select Case .Cells(i, 1).Value2
Case "10EE"
.Cells(i, "AX").Resize(1, 3) = .Cells(i, "AW").Resize(1, 3).Value2
.Cells(i, "AW").ClearContents
Case "05EE", "15EM"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "M").Resize(1, 2).Value2
.Cells(i, "M").Resize(1, 2).ClearContents
Case "11EE", "25CP", "26EP", "51CL", "60PM"
.Cells(i, "AY").Resize(1, 3) = .Cells(i, "L").Resize(1, 3).Value2
.Cells(i, "L").Resize(1, 3).ClearContents
Case "17EA"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "X").Resize(1, 2).Value2
.Cells(i, "X").Resize(1, 2).ClearContents
Case "20DP"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AC").Resize(1, 2).Value2
.Cells(i, "AC").Resize(1, 2).ClearContents
Case "24AH"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AD").Resize(1, 2).Value2
.Cells(i, "AD").Resize(1, 2).ClearContents
Case "30EL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "V").Resize(1, 2).Value2
.Cells(i, "V").Resize(1, 2).ClearContents
Case "31EL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "O").Resize(1, 2).Value2
.Cells(i, "O").Resize(1, 2).ClearContents
Case "40DE"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "R").Resize(1, 2).Value2
.Cells(i, "R").Resize(1, 2).ClearContents
Case "50CL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AB").Resize(1, 2).Value2
.Cells(i, "AB").Resize(1, 2).ClearContents
Case Else
'do nothing
End Select
Next i
end with
如果某些值出现的频率更高，它们应该位于 Case 条件的顶部。
另一种构造数据并使用数组的方法：
Option Explicit
Public Sub CopyVals()
Const START_ROW = 4
Dim ws As Worksheet, rng As Range, map As Variant, arr As Variant, mapUb As Long
Set ws = Sheet3 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
Set rng = ws.UsedRange
arr = rng 'Copy Range to Array
map = GetMapping(map) 'Get Mapping: Values to Columns
mapUb = UBound(map)
Dim r As Long, i As Long, j As Long
For r = START_ROW To rng.Rows.Count
For i = 1 To mapUb
If arr(r, 1) = map(i, 1) Then
For j = 0 To map(i, 4) 'map4 = Offset col
' map3 = copyTo col map2 = copyFrom col
arr(r, map(i, 3) + j) = arr(r, map(i, 2) + j)
Next
End If
Next
Next
rng.Offset(rng.Rows.Count + 1, 0) = arr
End Sub
Private Function GetMapping(ByRef map As Variant) As Variant
Const ITM = "10EE 05EE 11EE 25CP 26EP 51CL 60PM 15EM 17EA 20DP 24AH 30EL 31EL 40DE 50CL"
Const SRC = "49 13 12 12 12 12 12 13 24 29 30 22 15 18 28"
Const DST = "50 51 51 51 51 51 51 51 51 51 51 51 51 51 51"
Const OFF = "2 1 1 1 1 1 1 1 1 1 1 1 1 1 1" 'Total columns to copy From / To + 1
Dim v As Variant, s As Variant, d As Variant, o As Variant, i As Long
v = Split(ITM)
s = Split(SRC)
d = Split(DST)
o = Split(OFF)
ReDim map(1 To UBound(v) + 1, 1 To 4) As Variant
For i = 1 To UBound(v) + 1
map(i, 1) = v(i - 1) 'Values
map(i, 2) = s(i - 1) 'From First Col
map(i, 3) = d(i - 1) 'To First Col
map(i, 4) = o(i - 1) 'Total Cols (both From and To)
Next
GetMapping = map
End Function
.
Map Array returned by GetMapping()
Value From First Col To First Col Total Cols (+ 1)
map( 1, 1) = "10EE": map( 1, 2) = 49: map( 1, 3) = 50: map( 1, 4) = 2
map( 2, 1) = "05EE": map( 2, 2) = 13: map( 2, 3) = 51: map( 2, 4) = 1
map( 3, 1) = "11EE": map( 3, 2) = 12: map( 3, 3) = 51: map( 3, 4) = 1
map( 4, 1) = "25CP": map( 4, 2) = 12: map( 4, 3) = 51: map( 4, 4) = 1
map( 5, 1) = "26EP": map( 5, 2) = 12: map( 5, 3) = 51: map( 5, 4) = 1
map( 6, 1) = "51CL": map( 6, 2) = 12: map( 6, 3) = 51: map( 6, 4) = 1
map( 7, 1) = "60PM": map( 7, 2) = 12: map( 7, 3) = 51: map( 7, 4) = 1
map( 8, 1) = "15EM": map( 8, 2) = 13: map( 8, 3) = 51: map( 8, 4) = 1
map( 9, 1) = "17EA": map( 9, 2) = 24: map( 9, 3) = 51: map( 9, 4) = 1
map(10, 1) = "20DP": map(10, 2) = 29: map(10, 3) = 51: map(10, 4) = 1
map(11, 1) = "24AH": map(11, 2) = 30: map(11, 3) = 51: map(11, 4) = 1
map(12, 1) = "30EL": map(12, 2) = 22: map(12, 3) = 51: map(12, 4) = 1
map(13, 1) = "31EL": map(13, 2) = 15: map(13, 3) = 51: map(13, 4) = 1
map(14, 1) = "40DE": map(14, 2) = 18: map(14, 3) = 51: map(14, 4) = 1
map(15, 1) = "50CL": map(15, 2) = 28: map(15, 3) = 51: map(15, 4) = 1