I have a set of data where every third column is the same. I want to leave only the first column and other which are the same must be deleted.
At first I tried this code but it deleted wrong columns because in every loop other columns positions were altered.
Sub DeleteMultipleColumns()
Dim i As Integer
Dim LastColumn As Long
Dim ws As Worksheet
Set ws = Sheets("Arkusz2")
LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
ws.Activate
For i = 4 To (LastColumn - 2)
ws.Columns(i).Select
Selection.Delete Shift:=xlToLeft
i = i + 3
Next i
End Sub
After this I tried another one using Union. It doesn't work as well:
Sub DeleteMultipleColumns()
Dim i As Integer
Dim LastColumn As Long
Dim ws As Worksheet
Set ws = Sheets("Arkusz2")
LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
ws.Activate
For i = 4 To (LastColumn - 2)
Application.Union.Columns(i).Select
i = i + 3
Next i
Selection.Delete Shift:=xlToLeft
End Sub
So how to do it?
My new idea is to try with an array. Do I have other options?
This is the code that I've implemented after your very good answers (thanks: sam092, meohow, mattboy):
Sub DeleteMultipleColumns()
Dim i As Integer
Dim LastColumn As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = Sheets("Arkusz2")
LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column - 2
For i = LastColumn To 4 Step -3
ws.Columns(i).Delete Shift:=xlToLeft
Next i
Application.ScreenUpdating = True
End Sub
Reverse the direction. Start deleting from the right. I think you know how to modify your code
You can go backwards like this. Also, you don't need to select the column before deleting, you can simply delete it right away.
For i = ((LastColumn \ 4) * 4) To 4 Step -4
ws.Columns(i).Delete Shift:=xlToLeft
Next i
I upvoted Mattboy's code as the cleanest
It is possible to avoid the range loop and use an array as you suggest, although I post this more for kicks as the array generation is tricky
Uses Is it possible to fill an array with row numbers which match a certain criteria without looping?
Sub OneinThree()
Dim ws As Worksheet
Dim rng1 As Range
Dim x As String
Set ws = ActiveSheet
Set rng1 = Cells(1, ws.Cells(1, Columns.Count).End(xlToLeft).Column - 2)
x = Join(Filter(Application.Evaluate("=IF(MOD(column(A1:" & rng1.Address & "),3)=0,address(1,column(a1:" & rng1.Address & ")),""x"")"), "x", False), ",")
If Len(x) > 0 Then ws.Range(x).EntireColumn.Delete
End Sub
Related
This question already has answers here:
Excel VBA - Delete Rows Based on Criteria
(2 answers)
Closed 4 years ago.
In Excel, I want to delete entire row if a cell is blank.
This should count for A17:A1000.
Running the script it returns the error:
Run-time 1004 error
Method Range of object global failed
If I replace A17:A1000 with A it deletes some rows.
Sub DeleteBlanks()
Dim r As Long
Dim m As Long
Application.ScreenUpdating = False
m = Range("A17:A1000" & Rows.Count).End(xlUp).Row
For r = m To 1 Step -1
If Range("A17:A1000" & r).Value = "" Or Range("A17:A1000" & r).Value = 0 Then
Range("A17:A1000" & r).EntireRow.Delete
End If
Next r
Application.ScreenUpdating = True
End Sub
The main issue in your code is that it is counting wrong.
"A17:A1000" & r does not count the rows up but appends the number r to that string. So eg if r = 500 it will result in "A17:A1000500" but not in "A17:A1500" as you might expected.
To delete all rows where column A has a blank cell you can use
Option Explicit
Public Sub DeleteRowsWithBlankCellsInA()
Worksheets("Sheet1").Range("A17:A1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
This one deletes all blank lines at once and therefore is pretty fast. Also it doesn't need to disable ScreenUpdating because it is only one action.
Or if blank and zero cells need to be deleted use
Option Explicit
Public Sub DeleteRowsWithBlankOrZeroCellsInA()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define which worksheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = LastRow To 1 Step -1
If ws.Cells(iRow, "A").Value = vbNullString Or ws.Cells(iRow, "A").Value = 0 Then
ws.Rows(iRow).Delete
End If
Next iRow
End Sub
This one deletes line by line. Each delete action takes its time so it takes longer the more lines you delete. Also it might need to disable ScreenUpdating otherwise you see the line-by-line action.
An alternative way is to collect all the rows you want to delete with Union() and then delete them at once.
Option Explicit
Public Sub DeleteRowsWithBlankOrZeroCellsInA()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define which worksheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DeleteRange As Range
Dim iRow As Long
For iRow = LastRow To 1 Step -1 'also forward looping is possible in this case: For iRow = 1 To LastRow
If ws.Cells(iRow, "A").Value = vbNullString Or ws.Cells(iRow, "A").Value = 0 Then
If DeleteRange Is Nothing Then
Set DeleteRange = ws.Rows(iRow)
Else
Set DeleteRange = Union(DeleteRange, ws.Rows(iRow)) 'collect rows to delete
End If
End If
Next iRow
DeleteRange.Delete 'delete all at once
End Sub
This is also pretty fast because you have again only one delete action. Also it doesn't need to disable ScreenUpdating because it is one action only.
In this case it is also not necessary to loop backwards Step -1, because it just collects the rows in the loop and deletes at once (after the loop). So looping from For iRow = 1 To LastRow would also work.
There are multiple errors in your code.
First of all, your procedure should have it's scope declared.
Presumably in your case Private
You are incorrectly defining your Range() Please look at its definition
Range.Value = 0 is not the same as Range = "" or better yet IsEmpty(Range)
Looping from beginning to end when deleting individual rows will cause complications (given their indexes [indices(?)] change) - or to better word myself - it is a valid practice, but you should know what you're doing with the indexes. In your case it seems much easier to them them in the LIFO order.
Last but not least, you're unnecessarily complicating your code with certain declarations (not an error so to say, but something to be improved upon)
With all the considered, your code should look something like this:
Option Explicit
Private Sub remove_empty_rows()
Dim ws as Worksheet: Set ws = Sheets("Your Sheet Name")
Dim lr as Long
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim i as Long
For i = lr to 1 Step -1
If IsEmpty(ws.Cells(i, 1)) Then
ws.Rows(i).Delete
End If
Next i
End Sub
In general, without meaning to sound condescending, it looks like you have some learning gaps in your coding practice. I'd refer properly reading some documentation or tutorial first, before actually doing coding like this yourself.
Taking into account that A17 cell is a header, you could use AutoFilter instead of iterating over cells:
Sub FastDeleteMethod()
Dim rng As Range, rngFiltered As Range
Set rng = Range("A17:A" & Cells(Rows.Count, "A").End(xlUp).Row)
With rng
.AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:="="
On Error Resume Next
Set rngFiltered = rng.SpecialCells(xlCellTypeVisible)
If Err = 0 Then rngFiltered.EntireRow.Delete
On Error GoTo 0
End With
End Sub
I need some help with this macro. I have a workbook that is formatted pretty poorly, but consistently every time I open it. Among other things, the goal is to find the non-blank cells in column B and delete the entire 2 rows below and the 1st row above each of those populated B cells.
The first loop I have in the code works just the way I want it to, but the second loop seems to only work on the 1st instance of a populated B cell, but then it deletes everything else above it, like 500 cells worth of data.
Can someone explain to me why this is happening, and if you could find a way to combine both of those for loops into 1, that would be nice too.
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").Value <> "" Then
currentSht.Cells(i, "B").Offset(1).EntireRow.Delete
End If
Next i
Range("D3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
currentSht.Rows("1:1").EntireRow.Delete
currentSht.Range("c:d, f:g, i:k").EntireColumn.Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
End If
Next j
End Sub
Thank you
The second loop deletes everything because upon deletion of the lines above the found value, said value gets moved up and will be found again, triggering another deletion. To fix this, the quickest way would be to skip the next two lines by modifying j:
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
j = j - 2
End If
Next j
It really doesn't matter much if you are looping from top to bottom or vice versa. The only difference would be if there are two entries in column B near each other. In that case, the search order would determine which one is deleted. But is deletion really what you want? Maybe you could .Clear the contents of the rows instead of deleting them.
edit: here's the new code a bit cleaned up
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").value <> "" Then
'reference the row directly
currentSht.Rows(i + 1).Delete
End If
Next i
'Do not use selection if you can avoid it
Range("D3", Range("D3").End(xlToRight)).Delete Shift:=xlUp
currentSht.Rows(1).Delete
currentSht.Range("C:D, F:G, I:K").Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").value <> "" Then
currentSht.Rows(j - 1).Delete
currentSht.Rows(j - 2).Delete
j = j - 2
End If
Next j
End Sub
If you want to combine the loops the behavior of the macro will change because of the deletions that happen between the loops.
This is my first post. I've been trying to teach myself excel VBA and it has been quite challenging.
Anyways I have been working on loops and ranges etc etc.
Here's my dilemma:
Option Explicit
Sub Move_Data()
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
Dim result As String
result = "New Results"
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 3 To LastRow
For j = 1 To LastColumn
If Cells(i, 1) = result Then
j = j + 1
Cells(i, 1).Copy Destination:=ActiveSheet.Cells(i, j)
End If
Next j
Next i
End Sub
Little by little I have put the above together. Here's my question:
I am trying to look at all the values in column "A". Once "New Results" is found I want to copy not only this cell, but everything underneath it, to a column "J". Then find the string in column "B" and copy the range to column "K", etc.
So far the code finds "New Results" and moves it to column "B" which is expected since is the only code I have written. How can add another loop that will copy everything under "New Results" along with it and move it over to the new column. This way J will keep increasing and eventually I will have all the results broken down by columns.
Hopefully this makes sense.
Thanks all,
You dont have to loop through all the cells. Rather use the Find() method. It's more efficient I think.
Sub Move_Data()
Dim rngFound As Range
Dim intColLoop As Integer
Dim LastColumn As Integer
Dim result As String 'added in edit, forgot that, oops
Dim intColPaste As Integer 'added in edit
result = "New Results"
LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
With Cells
'in case the result is not on the ActiveSheet, exit code
If .Find(result) Is Nothing Then Exit Sub
'*****************Search all the columns, find result, copy ranges
'search all the columns
For intColLoop = 1 To LastColumn
With Columns(intColLoop)
'check if the result is in this column
If Not .Find(result) Is Nothing Then
'find the result
Set rngFound = .Find(result)
'copy the found cell and continuous range beneath it to the destination column
Range(rngFound, rngFound.End(xlDown)).Copy Destination:=Cells(Rows.Count, 10 + intColPaste).End(xlUp) 'Edit : changed the "10" to "10 + intColPaste"
intColPaste = intColPaste + 1 'Edit : added counter for columns
End If
End With
Next intColLoop 'proceed to next column
End With
End Sub
Very well written for your first post, congrats!
Option Explicit
Sub Move_Data()
Dim SourceCol As integer
Dim DestCol As Integer
Dim LastRow As Long
'Dim LastColumn As Long
Dim rng As Range
Dim result As String
Dim Addr as string
SourceCol = 1 'Column A
DestCol = 2 'Column B
result = "New Results"
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
set rng = ActiveSheet.Range(cells.Address).Find (What:=Result, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)
While not rng is Nothing and Addr <> rng.Range.Address
'If not rng is Nothing
ActiveSheet.range(cells(rng.row, DestCol),cells(LastRow,DestCol) = _
ActiveSheet.range(cells(rng.row,SourceCol), cells(LastRow,SourceCol))
'End If
Addr = rng.range.address(ReferenceStyle:=xlR1C1)
set rng = ActiveSheet.Range(cells.Address).Find (What:=Result, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)
wend
End Sub
Adjust SourceCol and DestCol as needed.
That's untested and off the top of my head, so it might need a minor tweak. Use .Find() to find your text, then set your destination range = to what you just found.
As written, it will find one occurrence of result. If you have multiple occurrences of result, comment out/delete the If... and 'End If` lines, then uncomment the 4 lines that are commented & they'll loop through, finding them all.
Essentially Im trying to copy and insert a certain range of cells on the second sheet as the program loops through a range of cells on the first sheet as long as the cells arent empty. I need the copy and insert range to change to the newly copy and inserted cells for each loop. Any help would be much appreciated
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim rng As Range
Dim i As Integer
Dim j As Integer
For i = 12 To 24
Set ws = ThisWorkbook.Sheets("Input")
With ws
If Not IsEmpty(Cells(i, 2)) Then
For j = 10 To -2
Set ws = ThisWorkbook.Sheets("Budget Output #2")
With ws
Set rng = .Range("Cell(5,i-j):Cell(17,i-j+1)")
rng.Copy
rng.Offset(0, 2).Insert Shift:=xlToRight
rng.Offset(0, 2).ColumnWidth = 20
Application.CutCopyMode = False
Next j
Next i
End If
End With
End With
End Sub
You do not need the With statements for ONE line. This will be much cleaner. Also with two sheets, you should use TWO sheet variables. Finally, I cleaned up your Range(Cells, Cells) syntax. Although, this will still not work because of your For j = 10 to -2. To move backwards, you have to use a Step -#.
Private Sub CommandButton1_Click()
Dim wsIn As Worksheet, wsOut As Worksheet
Dim rng As Range
Dim i As Integer
Dim j As Integer
Set wsIn = ThisWorkbook.Sheets("Input")
Set wsOut = ThisWorkbook.Sheets("Budget Output #2")
x = 2
For i = 12 To 24
If Not IsEmpty(wsIn.Cells(i, 2)) Then
Set rng = wsOut.Range("B:C")
rng.Copy
rng.Offset(0, x).Insert Shift:=xlToRight
rng.Offset(0, x).ColumnWidth = 20
Application.CutCopyMode = False
x = x + 2
End If
Next i
End Sub
I will let you figure out the answer. Here is the correct structure:
For i ....
For j ...
with ws
end with
next j
next i
You have two ws variables Possibly start your code out right.
Dim ws As Worksheet, sh As Worksheet
Set ws = Sheets("Budget Output #2")
Set sh = Sheets("Input")
I am trying to loop through a column and if cells = "what i'm lookng for" then do something.
I have this so far, where I'm off is in the if statement where I check for the "name":
Option Explicit
Sub test()
Dim wksDest As Worksheet
Dim wksSource As Worksheet
Dim rngSource As Range
Dim name As String
Dim LastRow As Long
Dim LastCol As Long
Dim c As Long
Application.ScreenUpdating = False
Set wksSource = Worksheets("Sheet1")
With wksSource
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For c = 16 To 20
LastRow = .Cells(.Rows.Count, c).End(xlUp).Row
Set rngSource = .Range(.Cells(5, 16), .Cells(LastRow, 16))
name = rngSource.Value
If name = "mark"
do something
End If
Next c
End With
Application.ScreenUpdating = True
'MsgBox "Done!", vbExclamation
End Sub
OK Chris
Maybe a bit of simplification is required but also a few assumptions.
It doesn't seem like LastCol is being used for anything - so let's assume this is the Column you want to loop through.
Your loop has fixed start and end values yet you are determining the LastRow - so let's assume you want to start from row 5 (in your code) and loop to the LastRow in the LastCol.
In order to determine LastCol you must have data in the row you are using to do this - so let's assume that there are values in row 1 in all columns up to column you want to loop say 16 (in your code).
If you want to (IF) test for a single (string) value in this case then you must arrange for your rngSource to be a single cell value. You also don't need to assign this to a variable unless you need to use it again.
Finally, if you want to check for other values you may want to consider using a SELECT CASE structure in place of your IF THEN structure.
Have a look at the following and change my assumptions to meet your requirement - good luck.
Sub test()
Dim wksDest As Worksheet
Dim wksSource As Worksheet
Dim rngSource As Range
Dim name As String
Dim LastRow As Long
Dim LastCol As Long
Dim c As Long
Application.ScreenUpdating = False
Set wksSource = Worksheets("Sheet1")
With wksSource
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(Rows.Count, LastCol).End(xlUp).Row
FirstRow = 5
For c = FirstRow To LastRow
If .Range(.Cells(c, LastCol), .Cells(c, LastCol)).Value = "Mark" Then
MsgBox ("do something")
End If
Next c
End With
End Sub
You can just do that with one line.
If Not IsError(Application.Match(ValueToSearchFor, RangeToSearchIn, 0)) Then
'The value found in the given range
End If
Example:
Search for "Canada" in column C of sheet named "Country"
If Not IsError(Application.Match("Canada", Sheets("Country").Range("C:C"), 0)) Then
'The value found in the given range
End If
Pass value to find and Column where value need to be checked. It will return row num if its found else return 0.
Function checkForValue(FindString As String,ColumnToCheck as String) As Long
SheetLastRow = Sheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).row
With Sheets("Sheet1").Range("$" & ColumnToCheck & "$1:$" & ColumnToCheck & "$" & CStr(SheetLastRow) )
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
checkForValue = rng.row 'return row its found
'write code you want.
Else
checkForValue = 0
End If
End With
End Function
I tried Hari's suggestion, but Application.Match works weird on range names (not recognizing them...)
Changed to: WorksheetFunction.Match(...
It works, but when value is not present A runtime ERROR jumps before IsError(...) is evaluated.
So I had to write a simple -no looping- solution:
dim Index as Long
Index = -1
On Error Resume Next
Index = WorksheetFunction.Match(Target,Range("Edificios"), 0) 'look for Target value in range named: Edificios
On Error GoTo 0
If Index > 0 Then
' code for existing value found in Range # Index row
End If
Remeber Excel functions first index = 1 (no zero based)
Hope this helps.
I'm guessing what you really want to do is loop through your range rngSource. So try
Set rngSource = .Range(.Cells(5, 16), .Cells(LastRow, 16))
for myCell in rngSource
if myCell.Value = "mark" then
do something
end if
next myCell