Excel VBA中的高效下壳体

Question

现在我使用下面的代码将整个列更改为小写。

我想知道是否有更有效的方法来实现这一点 - 我的工作表中有大约150K行。

完成需要一些时间，有时我会收到Out of Memory错误。

First Sub

Sub DeletingFl()
Dim ws1 As Worksheet
Dim rng1 As Range
Application.ScreenUpdating = False
Set ws1 = Sheets("Raw Sheet")

ws1.AutoFilterMode = False
Set rng1 = ws1.Range(ws1.[a1], ws1.Cells(Rows.Count, "A").End(xlUp))
rng1.AutoFilter 1, "Florida"
    If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then
    Set rng1 = rng1.Offset(1, 0).Resize(rng1.Rows.Count - 1)
    rng1.EntireRow.Delete
    End If
ws1.AutoFilterMode = False    
Call DeletingEC
End Sub

Sub DeletingEC()
Dim ws1 As Worksheet    
Dim rng1 As Range
Application.ScreenUpdating = False
Set ws1 = Sheets("Raw Sheet")

ws1.AutoFilterMode = False
Set rng1 = ws1.Range(ws1.[a1], ws1.Cells(Rows.Count, "A").End(xlUp))
rng1.AutoFilter 1, "East Coast"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then
    Set rng1 = rng1.Offset(1, 0).Resize(rng1.Rows.Count - 1)
    rng1.EntireRow.Delete
End If
ws1.AutoFilterMode = False
Worksheets("Raw Sheet").Activate    
Call Concatenating
End Sub

Second Sub

Sub Concatenating()

Columns(1).EntireColumn.Insert
Columns(2).EntireColumn.Copy Destination:=ActiveSheet.Cells(1, 1)

Dim lngLastRow As Long
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

    Range("A2:A" & lngLastRow).Formula = "=F2 & ""_"" & G2"
Range("A1").Select
    ActiveCell.FormulaR1C1 = "Title"       
Call LowerCasing
End Sub

Sub Lowercasing()
Dim myArr, LR As Long, i As Long
       LR = Range("A" & Rows.Count).End(xlUp).Row
myArr = Range("A1:A" & LR)
       For i = 1 To UBound(myArr)
              myArr(i, 1) = LCase(myArr(i, 1))
       Next i
Range("A1:A" & LR).Value = myArr
Set ExcelSheet = Nothing
End Sub

Answer 1

使用电子表格执行此操作。我在$A$1:$A$384188中添加了一些数据，并在$B$1:$B$384188中创建了一个数组公式：{=UPPER($A$1:$A$384188)}。这是立即的，并没有使用太多的记忆。

通过VBA循环将总是慢得多，内存密集。 您可以使用VBA创建公式，并按值复制粘贴数据。

Answer 2

您有时会收到错误，因为您尝试将多少内容打包到数组中。您放入该阵列的所有内容都必须符合您的可用内存。

这样的事情应该更好（注意这是未经测试的代码）：

Sub Lowercasing()
Const MaxArraySize As Integer = 1000
Dim myArr, Rng As Range, LR As Long, i As Long, j As Long, ArrayLen As Integer
       LR = Range("A" & Rows.Count).End(xlUp).Row
       Application.ScreenUpdating = False
       For i = 1 To LR Step MaxArraySize
           If LR - i < MaxArraySize Then
               ArrayLen = LR - i + 1
           Else
               ArrayLen = MaxArraySize
           End If
           Set Rng = Range("A" & i & ":A" & i + ArrayLen - 1)
           myArr = Rng
           For j = LBound(myArr) To UBound(myArr)
               myArr(j, 1) = LCase(myArr(j, 1))
           Next j
           Rng.Value = myArr
       Next i
       Application.ScreenUpdating = True
End Sub

一般的想法是在一系列较小的更新中进行更新。您可以使用MaxArraySize常量来在速度和内存使用之间找到一个很好的平衡。

您还需要添加错误处理程序，以确保在出现问题时重新启用ScreenUpdating。

Answer 3

看起来有一些冗余，绝对是阵列的问题。

我认为你可以删除Lowercasing（）函数并增强Concatenating来为你做小写：

Sub Concatenating()
    Dim lRowCount As Long
    Dim lngLastRow As Long

    'Do this first while values in column A
    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

    Columns(1).EntireColumn.Insert

    'Meh... :P
    'We're looping through code in the Lower Casing so no need to copy this and then loop through
    'Columns(2).EntireColumn.Copy Destination:=ActiveSheet.Cells(1, 1)



    For lRowCount = 1 To lngLastRow
        'I read a long time ago that LCase$ is faster than LCase; may not be noticable on today's machines
        'It wont' hurt to use LCase$
         Range("A" & lRowCount) = LCase$(Range("B" & lRowCount))
    Next lRowCount

        'Not sure what this does but may need to adjust accoringly
        Range("A2:A" & lngLastRow).Formula = "=F2 & ""_"" & G2"
        Range("A1").Select
        ActiveCell.FormulaR1C1 = "Title"

    'No need...already lower cased
    'Call Lowercasing
End Sub

Answer 4

这是另一种降低列中每个单元格的方法，也许值得一试：

Public Sub toLowerCase()
    Dim lr As Integer
    For lr = 1 To Application.ActiveSheet.UsedRange.Rows.Count
       Application.ActiveSheet.Cells(lr, 1) = LCase(Application.ActiveSheet.Cells(lr, 1).Value)
    Next lr
End Sub

不是创建数组并重置范围，而是简单地使用UsedRange并按原样设置值。这避免了对数组的需求，这在处理这种大小的数据时可能会出现问题。

仅供参考...我注意到你在代码片段中进行了复制。如果你正在复制大量的单元格，那么设置每个单元格值（例如cellTarget.Value = cellSource.Value）比将一个单元格值复制到另一个单元格值更快更多。

另外，我注意到您将 ScreenUpdating 设置为False ...您在哪里将其设置为True？除了在这些大型计算期间切换ScreenUpdating之外，您可能还需要考虑setting Calculation to manual。有时当工作表得到这么多活动时，Excel会经常计算。通过将其设置为manul，可以避免超出开销。

以下是使用上述相同代码段的示例，但这次提供了ScreenUpdating和Calculation设置：

Public Sub toLowerCase()
    Dim lr As Integer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For lr = 1 To Application.ActiveSheet.UsedRange.Rows.Count
       Application.ActiveSheet.Cells(lr, 1) = LCase(Application.ActiveSheet.Cells(lr, 1).Value)
    Next lr
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Answer 5

您可以在没有循环且没有工作列的情况下执行此操作

1. 将范围（单行或列）转储为1D字符串数组
2. 取小字符串并将其转回范围

码

Sub NoLoops()
Dim rng1 As Range
Dim strOut As String
Dim strDelim As String

strDelim = ","
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
X = LCase$(Join(Application.Transpose(rng1), strDelim))
rng1 = Application.Transpose(Split(X, strDelim))
End Sub

更短的版本

Sub OneLine()
Range([a1], Cells(Rows.Count, "A").End(xlUp)) = Application.Transpose(Split(LCase$(Join(Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp))), ",")), ","))
End Sub

<强> [Update for the 65536 cell limit with Transpose]

对于150k行，在Application Transpose给定限制的情况下，此方法需要 chunk 该列为2 ^ 16个部分。这是对“无循环”变成“最小循环”的烦人调整

Sub Transpose_Adjust()
Dim rng1 As Range
Dim rng2 As Range
Dim lngCnt As Long
Dim lngLim As Long
Dim lngCalac As Long
Dim strOut As String
Dim strDelim As String

With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With

strDelim = ","
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
'TRANSPOSE limited to 65536 cells
lngLim = Application.Min(16, Int(rng1.Cells.Count / 2 ^ 16))
For lngCnt = 1 To lngLim
Set rng2 = rng1.Cells(1).Offset((lngCnt - 1) * 2 ^ 16, 0).Resize(2 ^ 16, 1)
X = LCase$(Join(Application.TransPose(rng2), strDelim))
rng2.Value2 = Application.TransPose(Split(X, strDelim))
Next lngCnt

With Application
.ScreenUpdating = True
.EnableEvents = True
Calculation = lngCalc
End With

End Sub