Geek asks and answers

Effective bottom shell in Excel VBA

I am now using the code below to change the entire column to lowercase.

I was wondering if there is a more efficient way to do this - I have about 150K lines on my sheet.

It takes some time to complete, and sometimes I get an error 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
+5
source share
5 answers

It looks like there is a bit of redundancy and definitely a problem with the array.

I think you can remove the Lowercasing () function and strengthen Concatenating to make the bottom panel for you:

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 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
+3
source

, . $A$1:$A$384188 $B$1:$B$384188: {=UPPER($A$1:$A$384188)}. .

VBA . VBA .

+6

- , . , , .

- ( , ):

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 .

+3

, , :

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 . , .

FYI... , . , (, cellTarget.Value = cellSource.Value), .

, , ScreenUpdating False..., True? ScreenUpdating . , ​​ , 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
+1

  • ( ) 1D

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]

For rows of 150 thousand, this method requires that the column be divided into 2 ^ 16 parts, taking into account the restrictions on Application Transpose. Which is an annoying setting for "no loops" becoming "minimal loops."

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
0
source

More articles:


All Articles