Efektywna dolna obudowa w programie Excel VBA

Question

Teraz używam poniższego kodu, aby zmienić całą kolumnę na małe litery.

Zastanawiam się, czy istnieje bardziej wydajny sposób, aby to zrobić - Mam około 150 tysięcy wierszy w moim arkuszu.

Trwa to trochę czasu, a czasami pojawia się błąd Out of Memory.

Pierwszy 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 

drugie 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

Wygląda na to, że jest trochę nadmiarowości i na pewno problem z tablicą.

myślę, że można usunąć funkcję Lowercasing() i zwiększenia Konkatenowanie zrobić lowercasing dla Ciebie:

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 2

otrzymujesz błąd czasami z powodu, jak wiele rzeczy staramy się pakować do tablicy. Wszystko, co umieścisz w tej tablicy, musi zmieścić się w twojej dostępnej pamięci.

Coś jak to powinno działać lepiej (uwaga to jest kod niesprawdzone):

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 

Ogólną ideą jest, aby aktualizację w szeregu mniejszych aktualizacji. Możesz grać ze stałą MaxArraySize, aby znaleźć odpowiednią równowagę pomiędzy szybkością i wykorzystaniem pamięci.

Będziesz także chciał dodać moduł obsługi błędów, aby upewnić się, że funkcja ScreenUpdating zostanie ponownie włączona w przypadku problemów.

Answer 3

Oto kolejny sposób na lowercasing każdą komórkę w kolumnie, to może warto spróbować:

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 

Zamiast tworzyć tablicę i zerowanie zakresu, to po prostu używa UsedRange i ustawia wartość, jak to idzie . Dzięki temu unika się konieczności tworzenia tablic, co może stwarzać problemy podczas przeglądania danych o tej wielkości.

FYI ... Zauważyłem, że w swoim fragmencie kodu kopiujesz. Jeśli wykonujesz kopiowanie na dużej ilości komórek, jest to szybsze niż ustawienie każdej wartości komórki (np. cellTarget.Value = cellSource.Value) niż kopiowanie wartości jednej komórki do drugiej.

Zauważyłem również, że ustawiłeś ScreenUpdating na False ... gdzie przywracasz wartość True? Oprócz przełączania ScreenUpdating podczas tych dużych obliczeń, możesz pomyśleć o setting Calculation to manual. Czasami, gdy arkusze kalkulacyjne uzyskują tak dużą aktywność, program Excel będzie obliczał zbyt często. Ustawiając to na manul, unikasz over over.

Oto przykład przy użyciu tego samego fragmentu kodu powyżej, ale tym razem z ScreenUpdating i ustawień obliczaniu przewidzianym:

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 4

pomocą arkusza kalkulacyjnego, aby to zrobić. Umieściłem pewne dane w $A$1:$A$384188 i utworzyłem formułę tablicową w $B$1:$B$384188: {=UPPER($A$1:$A$384188)}. Jest natychmiastowy i nie wymaga dużej ilości pamięci.

Zapętlenie przez VBA będzie zawsze o wiele wolniejsze i będzie wymagać więcej pamięci. Możesz użyć VBA, aby utworzyć formułę i skopiować wkleić dane według wartości.

Answer 5

Można to zrobić bez pętli i bez kolumn pracujących

1. Dump zakres (pojedynczy wiersz lub kolumna) do tablicy łańcuchów 1D
2. Weź małą literę ciągu i zrzuć go z powrotem w zakresie

kod

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 

krótszych wersji

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]

Na 150K rzędach metoda musi fragmentu kolumnę do 2^16 części podany Limi ts na Application Transpose. Co jest irytujące regulacja „NO pętli” staje się „minimalne pętle”

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