I'm trimming all entries in a column (except header in row 1) to the last four characters using:
Range("A2").Select
Do While ActiveCell <> ""
ActiveCell = Right(ActiveCell.Value, 4)
ActiveCell.Offset(1, 0).Select
Loop
It works, but is quite slow on large files. Does anyone know how I could speed this up?
Along with the linked answers in the comments, I prefer to use variant arrays when looping. They are stored in memory. Whenever one accesses the work sheet vba needs to slow down. by limiting our interactions we can speed things up.
Sub right4()
With ActiveSheet 'better to use actual worksheet ie Worksheets("Sheet1")
Dim rng As Range
Set rng = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
End With
Dim rngarr As Variant
rngarr = rng.Value
Dim i As Long
For i = 1 To UBound(rngarr, 1)
rngarr(i, 1) = Right(rngarr(i, 1), 4)
Next i
rng.Value = rngarr
End Sub
If one wants to not use a loop:
Sub right4()
With ActiveSheet 'better to use actual worksheet ie Worksheets("Sheet1")
Dim rng As Range
Set rng = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
rng.Value = .Evaluate("INDEX(RIGHT(" & rng.Address(0, 0) & ",4),)")
End With
End Sub
Though I would guess that timing on the second will come a close second to the first code.
Related
I am trying to select all the data in a column and make it proper case.
This is what I'm starting with:
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
I think I want to use Application.WorksheetFunction.Proper.
Here is my approach to this, adjust the column index (rw.Row, 1) to suit your project
Sub ConvertValuesInColumnOneToProperCase()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rw As Range
For Each rw In ws.UsedRange.Rows
ws.Cells(rw.Row, 1) = StrConv(ws.Cells(rw.Row, 1), vbProperCase)
Next rw
End Sub
Please, try this way. The next code processes the values in column E:E. You can easily adapt it for another column. No need to select anything. Selecting, activating only consumes Excel resources without bringing any benefit:
Sub UcaseRange()
Dim sh As Worksheet, rng As Range
Set sh = ActiveSheet
Set rng = sh.Range("E2:E" & sh.Range("E" & sh.rows.count).End(xlUp).row)
rng = Evaluate("INDEX(UPPER(" & rng.Address(0, 0) & "),)")
End Sub
To this:
I would like the set of code to be able to pick up every blank in column C and perform a macro in it. It would have been easy if my sheet has a fixed range, however, my list is constantly increasing in rows... Hence, I would need the macro to be able to run macro on blank cells and skip on those filled cells. The macro should also end upon the last filled cell in the column.
Sub Testing()
Dim Rl As Long ' last row
Dim Tmp As Variant
Dim R As Long ' row counter
With ThisWorkbook.ActiveSheet ' modify to suit
Rl = .Cells(.Rows.Count, "C").End(xlUp).Row
' work on column C
For R = 1 To Rl ' start the loop in row 1
Tmp = .Cells(R, "C").Value
If Len(Tmp) Then
Cells(R, "C").Select
Call AutoFill
End If
Next R
End With
Sub AutoFill()
Application.EnableEvents = False
Dim rng As Range
Set rng = Range(Selection, Selection.End(xlDown))
Set rng = rng.Resize(rng.Rows.Count - 1, rng.Columns.Count)
rng.FillDown
End Sub
Your problem is here: If Len(Tmp) Then and that's just checking if Tmp has any length. So this actually ignores your empty cells by skipping them. Instead you are selecting cells with values in them.
Do not loop all cells in a range. Instead just look at those empty cells of interest. For example:
Sub Testing()
Dim LR As Long, LC as Long
Dim rng As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
LC = .Cells(LR, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(1, 1), .Cells(LR, LC))
If WorksheetFunction.CountBlank(rng) > 0 Then
For Each area In rng.SpecialCells(xlCellTypeBlanks).Areas
area.Offset(-1).Resize(area.Rows.Count + 1).FillDown
Next
End If
End With
End Sub
As you can see I left out .Select and ActiveSheet as that's poor coding and usually not needed at all.
Update: I realized that I can't use union on multiple sheets.
What's the best choice that I have then?
I simply want to combine all sheets in the workbook into the first worksheet.
After I went through the existing questions, I've tried adding Set rng = nothing to clear my range, but it didn't help.
Sub Combine()
Dim J As Long
Dim Combine As Range
Dim rng As Range
'I want to start from the second sheet and go through all of them
For J = 2 To Sheets.Count
With Sheets(J)
Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each Cell In rng
If Combine Is Nothing Then
Set Combine = Cell.EntireRow
Else
Set Combine = Union(Combine, Cell.EntireRow)
End If
Next Cell
Set rng = Nothing
Next J
'Paste the whole union into the 1st sheet
Combine.Copy Destination:=Sheets(1).Range("A1")
End Sub
All this code gets me an error Method 'Union' of object '_Global failed
Update 2
Sub Combine2()
Dim rowcount As Long
For Each Sheet In Sheets
If Sheet.Index <> 1 Then
rowcount = Sheet.UsedRange.Rows.Count
Sheet.UsedRange.Copy Destination:=Sheets(1).Cells(Lastrow + 1, 1)
Lastrow = Lastrow + rowcount
End If
Next Sheet
End Sub
Really simple code, worked perfectly, thanks to #luuklag for leading me on this.
Indeed .Union method doesn't work across worksheets.
Instead, you could try looping through all your worksheets, copying the corresponding range and pasting it to the destination worksheet.
Something like the following would achieve this:
Sub test()
Dim destinationSheet As Worksheet
Dim sht As Worksheet
Dim destinationRng As Range
Dim rng As Range
Set destinationSheet = ThisWorkbook.Worksheets("Name of your worksheet")
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> destinationSheet.Name Then
With sht
Set rng = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
rng.Copy
End With
With destinationSheet
Set destinationRng = .Range("A" & .Rows.Count).End(xlUp)
If destinationRng.Address = .Range("A1").Address Then
destinationRng.PasteSpecial xlPasteValues
Else
destinationRng.Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
End If
Next sht
End Sub
The code above pastes the ranges one by one, in the same column. It can be easily modified to paste the ranges in different columns, one next to the other.
I'm trying to compare sheet1 "A" column values to sheet2 "E:E" column values and copy/paste the whole line of every match to sheet3. Please help me to complete this task. I'm very new to VBA.
Thank you very much in advance!
Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("Sheet2").Range("E:E" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 1 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).EntireRow.Copy
Sheets("Sheet3").Select.Paste
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Sub DelDupsTwoLists()
Dim lastRowWs1 As Long, lastRowWs2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
lastRowWs1 = LastRow(ws1.Name, 1)
lastRowWs2 = LastRow(ws2.Name, 5) 'E = 5
Dim myCell1 As Range, myCell2 As Range
Dim ws1Range As Range, ws2Range As Range
Set ws1Range = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(lastRowWs1, 1))
Set ws2Range = ws2.Range(ws2.Cells(1, "E"), ws2.Cells(lastRowWs2, 1))
Dim rangeToDelete As Range
For Each myCell1 In ws1Range
For Each myCell2 In ws2Range
If myCell1.Value = myCell2.Value Then
Dim lastRowWs3: lastRowWs3 = LastRow(ws3.Name, 1) + 1
myCell2.EntireRow.Copy Destination:=ws3.Cells(lastRowWs3, 1)
If Not rangeToDelete Is Nothing Then
Set rangeToDelete = Union(rangeToDelete, myCell2.EntireRow)
Else
Set rangeToDelete = myCell2.EntireRow
End If
End If
Next
Next
If Not rangeToDelete Is Nothing Then
Debug.Print "Deleting rangeToDelete - "; rangeToDelete.Address
rangeToDelete.Delete
End If
Debug.Print "Done!"
End Sub
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
Pretty much I rewrote the whole code from scratch. It pretty much uses the initial n2 complexity, but is rather faster than that, because the deletion of the rows in WorkSheet(2) is done in a single last step rangeToDelete.Delete, which saves a lot of time.
Pretty much, the code defines 2 ranges with which is works - ws1Range and ws2Range, using the LastRow function. Once it defines them, it starts looping through them and comparing them. Hence the n2 complexity. In case of equal values, the row is copied and the cell is added to the rangeToDelete.
Note - it will probably not work as "out of the box solution", but try to debug further with F8 and see what happens.
Additionally:
Using Integer is not a great idea in VBA.
"_" in the Sub name is used for Events in VBA, thus it is not a great idea to use it. (although it works)
How to avoid using Select in Excel VBA
Give this a try (see comments in code for more details):
Sub DelDups_TwoLists()
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
With ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1") 'declare and set the source worksheet
Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet3") 'declare and set the destination worksheet
Dim R1 As Long, R2 As Long, C As Long, lRow As Long, lCol As Long 'declare variables to use
With wsSrc
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'get the last column value in the source sheet, at row 1, will reuse this laster
Dim arrData_1 As Variant: arrData_1 = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)) 'declare and allocate the source data to an array
End With
With .Sheets("Sheet2")
Dim arrData_2 As Variant: arrData_2 = .Range("E1:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'declare and allocate the compare data to an array
End With
End With
With wsDst
For R1 = LBound(arrData_1) To UBound(arrData_1) 'for each row in the source data
For R2 = LBound(arrData_2) To UBound(arrData_2) 'for each row in the compare data
If arrData_1(R1, 2) = arrData_2(R2, 1) Then 'if there is a match
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last row in the destination sheet
.Range(.Cells(lRow, 1), .Cells(lRow, lCol)).Value = _
wsSrc.Range(wsSrc.Cells(R1, 1), wsSrc.Cells(R1, lCol)).Value 'allocate the matching values
Exit For 'exit early here if there is a match, go to next row to check
End If
Next R2
Next R1
End With
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I'm trying to determine the minimum and maximum values of a 5 cell range (C:G) for all non-blank rows in a worksheet and place the respective results in columns L and M.
I'm getting a Run-time error '1004' Application-defined or object-defined error.
Sub test()
ActiveSheet.Range("A1").Select
ActiveCell.Offset(1, 0).Select
Do While ActiveCell.Value <> Empty
ActiveCell.Offset(0, 11) = WorksheetFunction.Min(Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 6)))
ActiveCell.Offset(0, 12) = WorksheetFunction.Max(Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 6)))
ActiveCell.Offset(1, 0).Select
Loop
ActiveSheet.Range("A1").Select
End Sub
I'm pretty sure my problem is in the specification of the range but not sure what it is.
The first and last selects are just a convention I use.
The second select is to step past a header row.
The third select is to increment the row.
If there is a simpler way to do this, please let me know.
I can't reproduce the error you mention, your code seems to run as is.
That said there a many ways to improve this code
Avoid Select (as mentioned in comments)
The Application object offers Min and Max functions, no need to use WorksheetFunctions for these
Better approach to range references is a combination of Offset and Resize
Your code, refactored to used these techniques
Sub Demo()
Dim ws As Worksheet
Dim rng As Range
Dim rw As Range
' Get a reference to the source data range
Set ws = ActiveSheet
With ws
Set rng = .Cells(2, 1)
' Just in case there is only one data row
If Not IsEmpty(rng.Offset(1, 0)) Then
Set rng = .Range(rng, rng.End(xlDown))
End If
End With
' Loop the range
For Each rw In rng.Rows
rw.Offset(0, 11) = Application.Min(rw.Offset(0, 1).Resize(, 5))
rw.Offset(0, 12) = Application.Max(rw.Offset(0, 1).Resize(, 5))
Next
End Sub
That said, you can go further and use a Variant Array approach. This runs much faster than looping a range (impact will vary depending on number of data rows)
Sub Demo2()
Dim ws As Worksheet
Dim rng As Range
Dim dat As Variant
Dim res As Variant
Dim i As Long
' Get a reference to the source data range
Set ws = ActiveSheet
With ws
Set rng = .Cells(2, 1)
' Just in case there is only one data row
If Not IsEmpty(rng.Offset(1, 0)) Then
Set rng = .Range(rng, rng.End(xlDown))
End If
End With
' Set up source and result arrays
dat = rng.Offset(, 2).Resize(, 5).Value
ReDim res(1 To UBound(dat, 1), 1 To 2)
With Application
' Loop the array
For i = 1 To UBound(dat, 1)
res(i, 1) = .Min(.Index(dat, i))
res(i, 2) = .Max(.Index(dat, i))
Next
End With
' Return results to sheet
rng.Offset(0, 11).Resize(, 2) = res
End Sub
Another technique is to avoid a loop entirely by (temporarily) placing formula into the sheet in one go. This will be much faster still (for more than a few data rows)
Sub Demo3()
Dim ws As Worksheet
Dim rng As Range
Dim rw As Range
' Get a reference to the source data range
Set ws = ActiveSheet
With ws
Set rng = .Cells(2, 1)
If Not IsEmpty(rng.Offset(1, 0)) Then
Set rng = .Range(rng, rng.End(xlDown))
End If
End With
' Place formulas into sheet
rng.Offset(0, 11).FormulaR1C1 = "=Min(RC[-9]:RC[-5])"
rng.Offset(0, 12).FormulaR1C1 = "=Max(RC[-9]:RC[-5])"
' replace formulas with values (optional)
rng.Value = rng.Value
End Sub
How about this?
Sub MinAndMax()
Dim rng As Range
Set rng = Range("A2:A" & Range("A2").End(xlDown).Row)
Range("L1") = WorksheetFunction.Min(rng)
Range("M1") = WorksheetFunction.Max(rng)
End Sub
Define the range upfront
Write the min and max to the cells directly