Need help creating a macro which removes initials (example : "T.") from column H if column J equals to "Company One".
I've tried the code below, but it has no effect. How can I go about this?
Option Explicit
Public Sub removeInitials()
With ThisWorkbook.ActiveSheet.UsedRange
If ActiveSheet.AutoFilter Is Nothing Then .AutoFilter
.AutoFilter Field:=10, Criteria1:="Company One"
.Columns(8).Offset(2).Replace What:=" *[A-Z].", Replacement:=""
.AutoFilter
End With
End Sub
If you don't have to large a database this should do the trick w/o messing with filters. Note: I changed the column for Employer for my example. I also changed the data a little to show it works thus the inclusion of the starting/ending points.
Public Sub removeInitials()
Dim wks As Worksheet
Dim lRow As Long
Set wks = ActiveSheet
lRow = 2
With wks
Do While (.Cells(lRow, 1) <> "")
If (.Cells(lRow, 3) = "Company Two" And Right(.Cells(lRow, 1), 1) = ".") Then
Debug.Print "Current Row " & lRow
.Cells(lRow, 1) = Left((.Cells(lRow, 1)), Len(.Cells(lRow, 1)) - 3)
End If
Debug.Print lRow
lRow = lRow + 1
Loop
End With
End Sub 'removeInitials
Starting Point
Ending Point
If you want to avoid VBA, you could just do a formula...put the below in cell K2 (or wherever...) and drag down.
=TRIM(IF(J2="Company One",SUBSTITUTE(H2,IFERROR(MID(H2,FIND(".",H2)-1,2),""),""),H2))
You could also have spill range as shown in column L in screen shot.
=FILTER(TRIM(IF(J2:J9999="Company One",SUBSTITUTE(H2:H9999,IFERROR(MID(H2:H9999,FIND(".",H2:H9999)-1,2),""),""),H2:H9999)),H2:H9999<>"")
If you really want a macro, here's a dynamic one that is pretty straight forward. A perfect answer would do an array, but looping through helps see what's happening.
Sub doReplace()
Dim changeRange As Range, aCell As Range, aPosition As Long
Const companySkip = "Company One"
Set changeRange = Intersect(Range("H:H"), ActiveSheet.UsedRange).Offset(1, 0)
For Each aCell In changeRange.Cells
If aCell.Offset(0, 2).Value = companySkip Then
aPosition = InStr(1, aCell.Value, ".", vbBinaryCompare)
If aPosition > 0 Then
aCell.Value = Trim(Replace(aCell.Value, Mid(aCell.Value, aPosition - 1, 2), ""))
End If
End If
Next aCell
End Sub
I made a few changes, and this worked:
Public Sub removeInitials()
Dim rng As Range
Set rng = ActiveSheet.UsedRange
With rng
.AutoFilter Field:=3, Criteria1:="Company One"
.Columns.Item(1).Replace What:=" ?.", Replacement:=""
.AutoFilter
End With
End Sub
And here is a before execution / after execution snapshot for a comparable example:
What I had to change to get it working:
The first parameter you are passing in the replace method wasn't working for me: " *[A-Z]."
Here is a very useful thread regarding pattern syntax, specifically for the replace method if you're interested: How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops
I wasn't sure why you used ".Columns(8).Offset(2)" (granted, I can't see the context of your Excel worksheet - but it seemed like you needed to return a range object for the single column with the names only - which you could then run the replace method on. That's what I did using ".Columns.Item(1)"
Related
I have the following sheet:
I want to delete the rows whereever the city column contains "USA". ex. the desired output is below:
My approach is to create another column at C2:C4 with the =isnumber(search("USA",B2)). Then
for i = lastrow to 2 step -1
If cells(i, "C") then
Else
rows(i).delete
end if
next
This method works, but I feel is very stupid and runs very slow on large datasets. Any thoughts on achieving this elegantly?
The following should do what you want - assumes the data is on Sheet1 in columns A and B.
Sub Del_USA()
Dim c As Range
With Sheet1.Range("B:B")
Set c = .Find("*USA*", LookIn:=xlValues)
If Not c Is Nothing Then
With Sheet1.Cells(1, 1).CurrentRegion
.AutoFilter 2, "*USA*", 7
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
.AutoFilter
End With
Else
MsgBox "USA Not Found"
End If
End With
End Sub
Solution via WorksheetFunction FILTER()
Profiting from the new dynamic array features of Microsoft 365 you could simply use a formula to filter a given range of e.g. A2:B5.
=FILTER($A$2:$B$5,ISERROR(FIND(UPPER("uSa"),UPPER($A$2:$B$5)))*(LEN($A$2:$B$5)))
This formula approach displays results at another spill range. -
As, however you want to overwrite the original source range, you'd have to code a VBA procedure like this using the same basic worksheet functionality via Evaluate() (see section B):
Example call
Note that Find() doesn't need wild cards and I adapted the following code to allow also a case insensitive search.
Sub ExampleCall()
DelCrit "uSa", Sheet1.Range("A2:B5")
End Sub
Procedure DelCrit
Sub DelCrit(ExcludeTerm As String, rng As Range, Optional ByVal colNum As Long = 2)
'Auth:
Const PATTERN$ = "=FILTER($,ISERROR(FIND(UPPER(""?""),UPPER(~)))*(LEN(~)))"
'~~~~~~~~~~~~~~~~
'A) adapt formula
'~~~~~~~~~~~~~~~~
Dim rngAddr As String: rngAddr = rng.Parent.Name & "!" & rng.Address
Dim colAddr As String: colAddr = rng.Parent.Name & "!" & rng.Columns(colNum).Address
Dim MyFormula As String
MyFormula = Replace(Replace(Replace(PATTERN, _
"$", rngAddr), _
"~", colAddr), _
"?", ExcludeTerm)
'~~~~~~~~~~~~~~~~~~~
'B) get result array
' (2-dim matrix or "flat" 1-dim array)
'~~~~~~~~~~~~~~~~~~~
Dim result: result = Evaluate(MyFormula) ' << Code evaluation
'~~~~~~~~~~~~~~~~
'C) write result
'~~~~~~~~~~~~~~~~
rng = vbNullString
On Error Resume Next
rng.Resize(UBound(result), UBound(result, 2)) = result
If Err.Number Then ' provide for 1-dim "flat" array
rng.Resize(1, UBound(result)) = result
End If
End Sub
I am trying to read all values in column G until it finds a blank cell. If values are "Permits Received" or "Cancelled" then I write "Ready to Build" in column H. If I encounter anything other than received or cancelled then I write "Missing Permits". So, I need to read ALL populated cells in column G and write ready... or missing... in column H. The problem with my code is 1) its probably not the best approach, and 2) it only reads the first cell in column G then writes the output.
This is for an automated workbook that works like a champ except for this loop. I have been goofing with For Next, Do While and For Each with varying success but the code below is the closest I've been.
Dim i As Integer, j As Integer, rng As Range
Set rng = Range("$G$2:$G$" & ActiveSheet.UsedRange.Rows.Count) ' Set range to all used rows in column G
For i = 2 To rng.Rows.Count
Do While Cells(i, 7).Value = ""
If Cells(i + 1, 7).Value = "Permits Received" Or Cells(i + 1, 7).Value = "Cancelled" Then
Cells(i, 8).Value = "Ready to Build"
Else: Cells(i, 8).Value = "Missing Permits"
End If
i = i + 1
If i = rng.Rows.Count Then Exit For ' Without this code it will read all rows, not just used rows
Loop
Next i
I expect the loop to read all column G values then decide if it is "Ready to Build" or "Missing Permits". The code runs to the 35766 then errs with Overflow if the Exit For is not included.
(new) I only need one output line (col H) per each line or group of lines (col G). The attached image shows how the output should look. Thank you so, so much for looking at this!!! I've been staring at it for a week!
Example of input and correct output, need code for column H
Example of output from latest solution
Solution based on the image published:
Assuming that the default value for any FIB:BUR group is "Missing Permits", unless all of its FIB:PERMITs have the values "Permits Received" or "Cancelled" then it should be marked as "Ready to Build".
This proposed solution uses AutoFilter object (Excel) combined with the Range.SpecialCells method (Excel). To create a range in which the groups are separated by Range.Areas property (Excel).
Then it uses For…Next and the WorksheetFunction.CountIf to validate the presence of "Permits Received" or "Cancelled", and Range.Offset Property (Excel) to set the resulting value for the group.
Sub Solution()
Dim rSrc As Range, rTrg As Range
Dim rArea As Range
Dim bCnt As Byte 'Change data type to long if the number of FIB:PERMITs by FIB:BUR exceeds 255
With ThisWorkbook.Worksheets("DATA") 'change as required
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
Set rSrc = .Cells(2, 7).Resize(-1 + .UsedRange.Rows.Count, 2)
End With
With rSrc
.Columns(2).ClearContents
.Offset(-1, 0).Resize(1 + .Rows.Count).AutoFilter
.AutoFilter Field:=1, Criteria1:="<>"
Set rTrg = .Columns(1).SpecialCells(xlCellTypeVisible)
.AutoFilter
End With
For Each rArea In rTrg.Areas
bCnt = 0
With WorksheetFunction
bCnt = .CountIf(rArea, "Cancelled")
bCnt = bCnt + .CountIf(rArea, "Permits Received")
rArea.Cells(1).Offset(-1, 1).Value2 = _
IIf(bCnt = rArea.Rows.Count, "Ready to Build", "Missing Permits")
End With: Next
End Sub
Answer to original question
Instead of using a Do…Loop within the For…Next, you could have used IF…ELSEIF or Select Case statement. This proposed solution uses Select Case
Sub Solution_1()
Dim rTrg As Range, lRow As Long
With ThisWorkbook.Worksheets("DATA") 'change as required
Set rTrg = .Cells(2, 7).Resize(-1 + .UsedRange.Rows.Count, 2)
End With
With rTrg
For lRow = 1 To .Rows.Count
Select Case .Cells(lRow, 1).Value2
Case vbNullString 'NO ACTION!
Case "Permits Received", "Cancelled"
.Cells(lRow, 2).Value2 = "Ready to Build"
Case Else
.Cells(lRow, 2).Value2 = "Missing Permits"
End Select: Next: End With
End Sub
However, I try to avoid For…Next whenever is possible, so this alternate solution uses
AutoFilter object (Excel) combined with the Range.SpecialCells method (Excel).
Sub Solution_2()
Dim rTrg As Range
With ThisWorkbook.Worksheets("DATA") 'change as required
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
Set rTrg = .Cells(2, 7).Resize(-1 + .UsedRange.Rows.Count, 2) ' Set range to all used rows in column G
End With
With rTrg
.Offset(-1, 0).Resize(1 + .Rows.Count).AutoFilter
.Columns(2).Value2 = "!"
.AutoFilter Field:=2, Criteria1:="!"
.AutoFilter Field:=1, Criteria1:="=Cancelled", _
Operator:=xlOr, Criteria2:="=Permits Received"
.Columns(2).SpecialCells(xlCellTypeVisible).Value2 = "Ready to Build"
.AutoFilter Field:=1, Criteria1:="<>"
.Columns(2).SpecialCells(xlCellTypeVisible).Value2 = "Missing Permits"
.AutoFilter Field:=1
.Columns(2).SpecialCells(xlCellTypeVisible).ClearContents
.Cells(1).AutoFilter
End With
End Sub
I've encountered a similar issue when using a for loop to iterate rows like that when I use an integer as the data type for my loop index variable. The Excel integer data is 2-bytes in length and has a range of -32,768 to 32,767. Perhaps your mention of "35766" was a typo for 32766 or 32767. If you change your variable 'i' from an int to a long, I would expect your issue to go away.
If this macro is something for your personal use rather than something others will be using, I've often used the following approach to iterate down one column and modify another cell that's on the same row:
Do While IsEmpty(ActiveCell.value) = False
If ActiveCell.value = "X" Then
ActiveCell.Offset(0, 1).value = "M" ' ActiveCell.Offset(row_offset, column_offset)
ElseIf ActiveCell.value = "Y" Then
ActiveCell.Offset(0, 1).value = "N"
End If
ActiveCell.Offset(1, 0).Activate ' From currently active cell, activate the next cell one row down
Loop
Before running a macro using this technique, you'd have to activate the first cell in the column being evaluated - which becomes the cell first evaluated as the ActiveCell.
Any alternative or suggestions to Fasten the below stated code that finds cells on multiple conditions and cut paste the same to another sheet.
Sub test()
'For Move Entire Row to New Worksheet if Cell Contains Specific Text's
'Using autofilter to Copy rows that contain certain text to a sheet called commodity
Dim LR As Long
Range("A2").EntireRow.Insert Shift:=xlDown
LR = Sheets("Data").Cells(Rows.Count, "E").End(xlUp).Row
LR1 = Sheets("Commodity").Cells(Rows.Count, "A").End(xlUp).Row + 1
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*SILVER*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*GOLD*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With Sheets("Data").Range("e:e")
.AutoFilter Field:=1, Criteria1:=("*MCX*")
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Destination:=Sheets("Commodity").Range("A" & LR1)
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
As well as the good suggestions #ShaiRado is making, what's slowing this down is your repeated interactions with the Excel functions and interface. Ideally, you'd read the data into variables within VBA, and then, all within VBA, check for matches and prepare an output array. That way you'd only have one interaction between VBA and Excel, namely to write the output array to your target sheet. It's also costly in time to delete one row at a time, so you might be better to create just one 'delete range' and hit it all in one go.
Skeleton code to achieve this is given below (but note, it will need a 'column offset' calculation if your used range doesn't start at "A", and you might choose a more reliable function than UsedRange). You call the routine like so:
TransferData "Silver", "Gold", "MCX"
And the routine itself might like something like this:
Private Sub TransferData(ParamArray searchItems() As Variant)
Dim srcData As Variant
Dim txData() As Variant
Dim item As Variant
Dim r As Long, c As Long
Dim txIndexes As Collection
Dim delRng As Range
'Read source data into an array
'Note: I've used UsedRange as I don't know your sheet layout
srcData = ThisWorkbook.Worksheets("Data").UsedRange.Value2
'Check for matches and record index number
Set txIndexes = New Collection
For r = 1 To UBound(srcData, 1)
For Each item In searchItems
If srcData(r, 5) = item Then
txIndexes.Add r
Exit For
End If
Next
Next
'Trasfer data to output array
ReDim txData(1 To txIndexes.Count, 1 To UBound(srcData, 2))
r = 1
For Each item In txIndexes
For c = 1 To UBound(srcData, 2)
txData(r, c) = srcData(item, c)
Next
r = r + 1
Next
'Write the transfer data to target sheet
With ThisWorkbook.Worksheets("Commodity")
.Cells(.Rows.Count, "A").End(xlUp).Resize(UBound(txData, 1), UBound(txData, 2)) = txData
End With
'Delete the transfered rows
For Each item In txIndexes
With ThisWorkbook.Worksheets("Data")
If delRng Is Nothing Then
Set delRng = .Cells(item, "A")
Else
Set delRng = Union(delRng, .Cells(item, "A"))
End If
End With
Next
If Not delRng Is Nothing Then delRng.EntireRow.Delete
End Sub
I am current using the below code snippet i found on stackxchg to delete rows that whereby there is no numeric value in column A. This works however it is gruesomely slow for a sheet with 5000 rows. Is there any way I can get this thing to go faster? The concept is, I have some rows that will kick out dates only if a criteria is met, and a chart will be generated using the dates in this column. I would like the chart range reference to change with the rows, but this is tough since there are formulas in the rows all the way down (and for a chart to look good the rows need to be completely empty). My workaround was to find a macro which could delete these rows (but it's going too slow using this code). Any help would be appreciated.
Sub Sample()
Dim LR3 As Long, i3 As Long
With Sheets("Basket Performance")
LR3 = .Range("A" & .Rows.Count).End(xlUp).Row
For i3 = LR3 To 2 Step -1
If Not IsNumeric(.Range("A" & i3).Value) Or _
.Range("A" & i3).Value = "" Then .Rows(i3).Delete
Next i3
End With
End Sub
You can do a single delete at the end of your loop:
Sub Sample()
Dim LR3 As Long, i3 As Long, rng As Range
With Sheets("Basket Performance")
LR3 = .Range("A" & .Rows.Count).End(xlUp).Row
For i3 = LR3 To 2 Step -1
If Not IsNumeric(.Range("A" & i3).Value) Or _
.Range("A" & i3).Value = "" Then
If rng Is Nothing Then
Set rng = .Cells(i3, 1)
Else
Set rng = application.union(rng, .Cells(i3, 1))
End If
End If '<<EDIT
Next i3
End With
If Not rng Is Nothing then rng.Entirerow.Delete
End Sub
you can try this
Option Explicit
Sub delrow()
With ThisWorkbook.Worksheets("Basket Performance")
.Columns("A").Insert '<== insert a "helper" column for counting and sorting purposes. it'll be removed by the end of the macro
.Columns("B").SpecialCells(xlCellTypeConstants, xlNumbers).Offset(, -1).FormulaR1C1 = "=COUNT(R1C[1]:RC[1])"
.Cells.Sort key1:=.Columns("A"), order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo
.Columns("A").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete '<== maybe you don't need to delete but just define the chart range reference from row 1 down to the last row in column A with a number
.Columns("A").Delete '<== remove the "helper" column
End With
End Sub
you may want to consider not deleting "non numeric" rows once sorted out, and just defining the chart range reference from row 1 down to the last row in column A with a number instead
All of the below methods have failed to reference the last column. What is a viable method?
For example 'Columns("1:" & llc.Address & "").Select through 'Columns("E:" & llc & "").Selectare trying to select sayColumns("E:N")`. But the last column is dynamic. In one instance it's column N, and in another application of the macro it's column AP.
Sub RestorePivtTable()
Set ws = ThisWorkbook.Sheets("sheet1")
llc = ws.Cells(2, ws.Columns.count).End(xlToLeft).Column
'Columns("1:" & llc.Address & "").Select
'Columns(1, llc).Select
'Range(Columns(1), Columns(llc)).Select
'Columns("E:" & Cells(3, llc).Address & "").Select
'Range("1:" & Cells(3, lc).Address & "").Select
'Range(Cells(1, 1).Address, Cells(3, llc).Address).Select
'Columns("E:" & llc & "").Select
Selection.ClearFormats
End Sub
If you are using your above method you will need to find the correct row to use. ie: you will need to know the row in which the data appears in the right-most column. If you want the last column out of anything, try:
ws.usedrange.columns
This just gives the number of columns in the used range of a sheet, which is defined as A1:[The bottom right cell which contains either values or formatting].
Note that this will not work if, say, you have formatting in E10, but you want to get column D, because D is the last column which has a value [ie: you want to exclude consideration of formatted cells].
I generally use this method, although you have to put checks in in case the sheet is empty (you can't return column 0).
Sub FindLastColumn()
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets("Sheet1")
MsgBox wrkSht.Cells.Find(What:="*", After:=wrkSht.Cells(1, 1), SearchDirection:=xlPrevious).Column
End Sub
Basic example of how to find the last column in your sheet - I've included an If block in case the sheet is empty, but then I don't know why you would run this code on an empty sheet anyway...
Sub SO()
Dim lastCol As Integer
Dim lastCell As Excel.Range
'// Assuming the variable 'ws' has already been dimensioned and initialised
On Error Resume Next
Set lastCell = ws.Cells.Find(What:="*", After:=ws.Range("A1"), SearchDirection:=xlPrevious)
On Error GoTo 0
If lastCell Is Nothing Then
lastCol = 1
Else
lastCol = lastCell.Column
End If
MsgBox lastCol
End Sub
UsedRange can be unreliable in this instance, because it can still contain cells that were previously used but are now blank - and I'm guessing you're not interested in these cells. Using the Cells.Find() method means that you don't have to know which row will coincide with the last column (which is needed for Columns.Count.End(xlToLeft) method) so this is a bonus too when working with irregular data sets.
Trying to "read between the lines" of your code, I suspect that this is what you are after:
Public Sub RestorePivtTable()
Sheet1.Cells(2, Sheet1.Columns.Count).End(xlToLeft).EntireColumn.ClearFormats
End Sub
This will work as long as there are data in row 2.
Thanks everyone for your help. The below function and macro solved the issue of converting a column number reference into a letter reference:
Function GetColumnLetter(colNum As Long) As String
Dim vArr
vArr = Split(Cells(1, colNum).Address(True, False), "$")
GetColumnLetter = vArr(0)
End Function
Sub RestorePivtTable2()
Dim lc As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("PivtTable")
lc = ws.Cells(5, ws.Columns.count).End(xlToLeft).Column
myCol = GetColumnLetter(lc)
Columns("E:" & myCol & "").Select
Selection.ClearFormats
End Sub