I'm trying to write a macro that removes rows with the condition that the string in the cells in column A contains "--" or "-4" or "" (empty). I'd do it with a normal filter, but that gives me max 2 conditions.
Sub Delete_Rows()
Dim cell As Range
For Each cell In Range("A:A")
If cell.Value = "*--*" Or cell.Value = "*-4*" Then
cell.EntireRow.Delete
End If
Next cell
End Sub
What am I doing wrong?
Please, test the next version. It uses an array for iteration and a Union range to delete rows at once, at the end of the code:
Sub Delete_Rows3Cond()
Dim sh As Worksheet, lastR As Long, rngDel As Range, arr, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A1:A" & lastR).Value2 'place the range in an array for faster iteration/processing only in memory
For i = 1 To UBound(arr)
If arr(i, 1) = "" Or arr(i, 1) Like "*--*" Or arr(i, 1) Like "*-4*" Then
addToRange rngDel, sh.Range("A" & i) 'create the union range
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
Private Sub addToRange(rngU As Range, Rng As Range) 'I creates the Union range
If rngU Is Nothing Then
Set rngU = Rng
Else
Set rngU = Union(rngU, Rng)
End If
End Sub
Deleting a row at a time, takes a lot of time and you need to process only the range containing data...
Please, send some feedback after testing it.
= checks for identical strings, so unless you have a cell containing "*--*" or "*-4*", the If-clause will never be true. You will have to use the like-operator:
If cell.Value like "*--*" Or cell.Value like "*-4*" Then
Two remarks:
Your code will loop through the whole Excel sheet (which contains 1'048'576 rows) so that will run a very long time. And, even worse, if you add the check for empty cells to delete a row, it will delete one million rows and it would look as if Excel/VBA is frozen. Therefore you need to figure out the last row before you run the code. More on this at Find last used cell in Excel VBA
And you need to be aware the that code will run on the active sheet - the sheet that currently has the focus. You should always specify the sheet (and workbook) where you want to code to work with. Don't go down the path to Select the sheet to make if active. For more details, see How to avoid using Select in Excel VBA
Sub Delete_Rows()
Dim cell As Range, lastRow As Long
' Replace the following line with the workbook you want to work with
With ThisWorkbook.Sheets(1)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
For Each cell In .Range("A1:A" & lastRow)
If cell.Value Like "*--*" Or cell.Value Like "*-4*" Then
cell.EntireRow.Delete
End If
Next cell
End With
End Sub
You can use the Like operator instead of "=" to perform the comparison. Consider the following the code:
Sub Delete_Rows()
Dim cell As Range
For Each cell In Range("A:A")
If cell.Value Like "*--*" Or cell.Value Like "*-4*" Then
cell.EntireRow.Delete
End If
Next cell
End Sub
You can also read more about the like operator here for example: https://www.wallstreetmojo.com/vba-like/
I hope this helps :D
Related
I've written a script which is supposed to compare the content of column A between two sheets in a workbook to find out if there are partial matches. To be clearer: If any of the content of any cell in coulmn A in sheet 1 matches any of the content of any cell in coulmn A in sheet 2 then that will be a match and the script will print that in immediate window.
This is my attempt so far:
Sub GetPartialMatch()
Dim paramlist As Range
Set paramlist = Sheets(1).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each cel In Sheets(2).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If InStr(1, cel(1, 1), paramlist, 1) > 0 Then 'I used "paramlist" here as a placeholder as I can't use it
Debug.Print cel(1, 1)
End If
Next cel
End Sub
The thing is I can't make use of this paramlist defined within my script. I just used it there as a placeholder.
a very fast approach is given by the use of arrays and Application.Match() function:
Sub GetPartialMatch()
Dim paramlist1 As Variant, paramlist2 As Variant
Dim cel As Range
Dim i As Long
paramlist1 = Sheets(1).Range("A2", Sheets(1).Cells(Rows.Count, 1).End(xlUp)).Value ' collect all sheets(1) column A values in an array
paramlist2 = Sheets(2).Range("A2", Sheets(2).Cells(Rows.Count, 1).End(xlUp)).Value ' collect all sheets(2) column A values in an array
For i = 1 To UBound(paramlist1) ' loop through paramlist1 array row index
If Not IsError(Application.Match(paramlist1(i, 1), paramlist2, 1)) Then Debug.Print paramlist1(i, 1) ' if partial match between current paramlist1 value and any paramlist2 value, then print it
Next
End Sub
if you want an exact match just use 0 as the last parameter in Match() function, i.e.:
If Not IsError(Application.Match(paramlist1(i, 1), paramlist2, 0)) Then Debug.Print paramlist1(i, 1) ' if exact match between current paramlist1 value and any paramlist2 value, then print it
BTW, if you need an exact match you could also use Autofilter() method of Range object with xlFilterValues as its Operator parameter:
Sub GetPartialMatch2()
Dim paramlist As Variant
Dim cel As Range
paramlist = Application.Transpose(Sheets(1).Range("A2", Sheets(1).Cells(Rows.Count, 1).End(xlUp)).Value) ' collect all sheets(1) column A values in an array
With Sheets(2).Range("A1", Sheets(2).Cells(Rows.Count, 1).End(xlUp)) ' reference sheets(2) column A cells from row 1 (header) down to last not empty one
.AutoFilter field:=1, Criteria1:=paramlist, Operator:=xlFilterValues ' filter referenced range with 'paramlist'
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then ' if any filtered cell other then header
For Each cel In .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' loop through all sheets(2) filtered cells but the header
Debug.Print cel.Value2
Next
End If
.Parent.AutoFilterMode = False 'remove filter
End With
End Sub
You want a double loop.
Sub GetPartialMatch()
Dim paramlist As Range
Dim cel as Range, cel2 as Range ; declare all variables!
Set paramlist = Sheets(1).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each cel In Sheets(2).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each cel2 in paramlist 'Sheets(1).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If InStr(1, cel(1, 1), cel2, 1) > 0 Then
Debug.Print cel(1, 1)
End If
Next cel2
Next cel
End Sub
Always use Option Explicit. Always.
This may be easier using a helper column and a formula, where the row in the helper column indicates TRUE if a MATCH is found. No VBA then. And it will be inherently faster.
Have you tried adding in:
Application.Screenupdating = false
Application.Calculation = xlCalculationManual
...Code...
Application.Screenupdating = true
Application.Calculation = xlCalculationAutomatic
These turn off the screen updating and automatic calculation of formulas within your instance of excel which can help speed up code a lot, you just have to remember to turn them back on at the end or you might give yourself a bit of a headache. It should be noted, though, that if you turn off screenupdating you won't be able to see the results roll in. You'll have to scroll backwards at the end
Another thing to consider would be store the data in an array before hand and doing the operations to the array and simply pasting it back in to the sheet. Accessing the sheet excessively slows down code drastically. Working with the accepted answer provided by #AJD, I made a few changes that will hopefully speed it up.
Sub macro()
Dim paramlist() As Variant
Dim DataTable() As Variant
Dim cell1 As Variant
Dim cell2 As Variant
paramlist() = Sheets(1).Range("A2:A" & Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row).Value
DataTable() = Sheets(2).Range("A2:A" & Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row).Value
For Each cell1 In paramlist
For Each cell2 In DataTable
If InStr(1, cell2, cell1, 1) > 0 Then
Debug.Print cell1
exit for
End If
Next cell2
Next cell1
End Sub
I would have suggested this under the accepted answer as a suggestion, but unfortunately, I don't have enough rep to comment yet.
Edit: switching the order of the for loops allows you to insert a more efficient exit for and can allow you to skip large portions of data within the search array
Not sure if this is any faster (it uses pretty much the same algorithm, a loop inside of a loop), but I would argue it's a bit clearer:
Sub SearchForPartialMatches()
Dim needle1 As Range, needle2 As Range
Set needle1 = Excel.Worksheets(1).Range("$B$2")
Do While needle1.Value <> ""
Set needle2 = Excel.Worksheets(2).Range("$B$2")
Do While needle2.Value <> ""
If InStr(1, needle1.Value, needle2.Value) > 0 Then
Debug.Print needle1.Value, needle2.Value
End If
Set needle2 = needle2.Offset(rowoffset:=1)
Loop
Set needle1 = needle1.Offset(rowoffset:=1)
Loop
End Sub
The main difference is it's not looping over the entire column, but instead starts at the top, and uses the offset method until there are no more rows (with data).
Of course, you'll need to change the starting cell for needle1 and needle2.
I ran this with the EFF large word list copied into both sheets, and it ran in about 4 minutes (which was less time than with #AJD, but that might've been a fluke). YMMV.
Just one more option. Not much different from any suggestions above ... The concept is to speed up processing by minimizing VBA - Excel interactions by loading the values to arrays and processing arrays like this:
Dim cel as String, cel2 as String
Dim arr1() as String, arr2 As String
arr1 = Sheets(1).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
arr2 = Sheets(2).Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
For Each cel In arr1
For Each cel2 in arr2
If InStr(1, cel, cel2, 1) > 0 Then
Debug.Print cel
End If
Next cel2
Next cel
I'd like to know if it helps at all :)
I'm trying to figure out a dynamic range that will select a range starting from the active cell in a for each loop. For instance, if cell A2 is selected in my for each cell loop, the range in the loop being A2:A20, and it contains "IP," it will select the range A2:M2, delete the contents, and shift all the values below, A3:M20, up to fill the emptied cells.
Sub deletewirelessdevice()
Dim rng As Range
Dim wksSource As Worksheet
Set wksSource = ActiveWorkbook.Sheets("dt-attext")
Set rng = wksSource.Range("A2:A500")
For Each Cell In rng
If InStr(1, ActiveSheet.Range(ActiveCell).Value, "IP") > 0 Then
Range(ActiveCell, "M" & ActiveCell.Row).Select.Delete Shift:=xlUp
Next Cell
End Sub
I'm not sure if there is a mistake in the selection and deletion as I can't get the code to run due to a Next without for compile error. There is a matching for so I don't know what the problem is. Any advice is welcome.
You had a number of issues with your code so I've tweaked it and inferred what you intended. This should work, however do read the comments above as well for some pointers on how to handle it next time
Public Sub deletewirelessdevice()
Dim DelRng As Range
Dim ColOffset As Long
With ActiveWorkbook.Sheets("dt-attext")
ColOffset = Range("M" & 1).Column - 1
For Each cell In .Range("A2:A500")
If InStr(cell.Value2, "IP") Then
If DelRng Is Nothing Then
Set DelRng = Range(cell, cell.Offset(0, ColOffset))
Else
Set DelRng = Union(DelRng, Range(cell, cell.Offset(0, ColOffset)))
End If
End If
Next cell
If Not DelRng Is Nothing Then DelRng.Delete Shift:=xlUp
End With
End Sub
I just want to know how to loop through the non blank cells on Column A. What I'm trying to do is copy the contents on [A1:B1] to be added on top of each non blank cells on Column A. So far I have counted the non blank cells on column A but I'm stuck. I know that an Offset function should be used for this.
Here's my code so far:
Dim NonBlank as Long
NonBlank = WorksheetFunction.CountA(Worksheet(1).[A:A])
For i = 1 to NonBlank
[A1:B1].Copy Offset(1,0). "I'm stuck here"
Next i
If you are trying to fill the headers for each Product, try this...
Sub FillHeaders()
Dim lr As Long
Dim Rng As Range
lr = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
On Error Resume Next
Range("A1:B1").Copy
For Each Rng In Range("A3:A" & lr).SpecialCells(xlCellTypeConstants, 2).Areas
If Rng.Cells(1).Value <> Range("A1").Value Then
Rng.Cells(1).Offset(-1, 0).PasteSpecial xlPasteAll
End If
Next Rng
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
As example to simulate the effect of Ctrl-Down from Cell A1 and display the Address, Value in the Immediate Window:
Sub HopToNextNonBlankCellBelow()
Dim oRng As Range
Set oRng = Range("A1")
Debug.Print "Cell Address", "Cell Value"
Do
Set oRng = oRng.End(xlDown)
If Not IsEmpty(oRng) Then Debug.Print oRng.Address(0, 0), oRng.Value
Loop Until oRng.Row = Rows.Count
Set oRng = Nothing
End Sub
Try this... I've (probably) overcounted the rows at 1000, but it likely won't make a difference with your performance. If you wanted to be more precise, there are hundreds of articles on how to find the last row of a range. As for the Offset function, it references a cell in relation to the one we're looping through. In the example below, the code is saying cell.offset(0,1) which means one cell to the right of the cell we are currently looping through. A clearer (less loopy!) example would be if you typed: Range("A10").offset(0,1) it would be the same as typing Range("B10")
Dim Cell As Range
For Each Cell In Range("A2:A1000").Cells
If Not IsEmpty(Cell) Then
Cell.Offset(0, 1).Value = Cell.Value
End If
Next Cell
I have section title cells set at 10 pt font while all other data is set at 9 point font in column A. I am trying to write a vba macro to loop through column A to move each title cell down one row(because the csv leaves a blank cell below them) then move on to the next title cell in the column. Here is my attempt but I'm not sure what I'm doing wrong here.
Sub FontSpacing()
Dim Fnt As Range
For Each Fnt In Range("A8:A5000")
If Fnt.Font.Size = "10" Then
ActiveCell.Cut Destination:=ActiveCell.Offset(",1")
End If
Next
Try this
Sub FontSpacing()
Dim r As Range
For Each r In ThisWorkbook.Worksheets("Sheet1").Range("A8:A5000")
If r.Font.Size = 10 Then
r.Offset(1,0).Value = r.Value
r.Value = vbNullString
End If
Next r
End Sub
The issues:
Offset(",1") shouldn't have the speech marks. I.e. it should be Offset(0,1). In fact, if you want to paste to the row below, then it should be Offset(1,0).
Avoid using ActiveCell. It's not the cell that is looping through your range, it's just the cell that was active on the worksheet when you ran the sub.
Fnt is a bad name for a range, it's probably the reason you got confused. When declaring (dimensioning) a range, try to give it a name that makes it clear you're working with a range.
Extra:
Fully qualify your range reference to avoid an implicit reference to the ActiveSheet e.g. ThisWorkbook.Worksheets("Sheet1").Range("A1").
Avoid cutting an pasting by setting the Value directly
Your indentation is out, which makes it look like a complete Sub, but it's missing the End Sub.
Not sure if you meant 1 Row below or 1 Column right so:
To shift 1 Column:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
cell.Offset(0, 1).Value = cell.Value
cell.Clear
End If
Next
End Sub
To shift 1 Row:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
a = cell.Row + 1
Rows(a & ":" & a).Insert Shift:=xlDown, CopyOrigin:=1
cell.Offset(1, 0).Value = cell.Value
cell.Offset(1, 0).Font.Size = "11"
cell.Clear
End If
Next
End Sub
I've seen several questions asking about moving cells from one workbook to another or one sheet to another using VBA, but I'm hoping to move information from one column to another in the same sheet based on specific criteria.
I wrote this code to move cells from column A if they contained the word "save" to column I in the same sheet:
Sub Findandcut()
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Jan BY").Range("A2:A1000")
For Each cell In rngA
If cell.Value = "save" Then
cell.EntireRow.Cut
Sheets("Jan BY").Range("I2").End(xlDown).Select
ActiveSheet.Paste
End If
Next cell
End Sub
But, while this macro doesn't display any errors when I run it, it also doesn't seem to do much of anything else, either. Nothing is selected, cut, or pasted. Where in the code did I go wrong?
move cells from column A if they contained the word "save" to column I
in the same sheet
Your code doesn't do anything like this.
To accomplish what your requirements are, you would need something like this:
Sub Findandcut()
Dim row As Long
For row = 2 To 1000
' Check if "save" appears in the value anywhere.
If Range("A" & row).Value Like "*save*" Then
' Copy the value and then blank the source.
Range("I" & row).Value = Range("A" & row).Value
Range("A" & row).Value = ""
End If
Next
End Sub
Edit
If you want to shift the entire contents of row over so it starts at column I, just replace the relevant section of code:
If Range("A" & row).Value Like "*save*" Then
' Shift the row so it starts at column I.
Dim i As Integer
For i = 1 To 8
Range("A" & row).Insert Shift:=xlToRight
Next
End If
Perhaps something like:
Sub Findandcut()
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Jan BY").Range("A2:A1000")
For Each cell In rngA
If cell.Value = "save" Then
cell.Copy cell.Offset(0, 8)
cell.Clear
End If
Next cell
End Sub
This code scans down the column, detects the matches and performs the copy. Copying brings over the format as well as the value.
Sub Findandcut()
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Jan BY").Range("A2:A1000")
For Each cell In rngA
If cell.Value = "save" Then
Sheets("Jan BY").Range("I" & Rows.Count).End(xlUp).Select
Selection.Value = cell.Value
cell.Delete Shift:=xlUp
End If
Next cell
End Sub