i want to build a macro that delete rows from a table in an excel sheet based on an if statement that runs on all the rows from row number 2 to the end of the table - if the value in row i and column B equals 0 i would like to delete the entire row.
this is the code i wrote but nothing happens when i run it
Sub deleteZeroRows()
'loop for deleting zero rows
Dim wbCurrent As Workbook
Dim wsCurrent As Worksheet
Dim nLastCol, i As Integer
Set wbCurrent = ActiveWorkbook
Set wsCurrent = wbCurrent.ActiveSheet
Dim lastRow As Long
lastRow = Range("b2").End(xlDown).Select
For i = 2 To lastRow
If wsCurrent.Cells(i, 2) = 0 Then
wsCurrent.Cells(i, 2).EntireRow.Delete
End If
Next i
End Sub
A faster method to delete multiple rows from your worksheet is to store all the Rows that need to be deleted in a Range, using the Union function.
After you exit your For loop, just delete the entire rows DelRng at one command.
More notes in my code's comments below.
Code
Option Explicit '<-- always use this at the top of your code
Sub deleteZeroRows()
Dim wbCurrent As Workbook
Dim wsCurrent As Worksheet
Dim lastRow As Long, nLastCol As Long, i As Long
Dim DelRng As Range
Set wbCurrent = ActiveWorkbook '<-- try to avoid using Active...
Set wsCurrent = wbCurrent.ActiveSheet '<-- try to avoid using Active...
With wsCurrent
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row ' get last row in column B
For i = 2 To lastRow
If .Range("B" & i).Value = 0 Then
If Not DelRng Is Nothing Then
' add another row to DelRng range
Set DelRng = Application.Union(DelRng, .Rows(i))
Else
Set DelRng = .Rows(i)
End If
End If
Next i
End With
' if there's at least 1 row to be deleted >> delete all rows in DelRng at 1-line
If Not DelRng Is Nothing Then DelRng.Delete
End Sub
a "fast & furious" code:
Sub deleteZeroRows()
With Range("B2", Cells(Rows.Count, 2).End(xlUp)) 'reference column B cells from row 2 down to last not empty one
.Replace what:=0, lookat:=xlWhole, replacement:="" ' replace 0's with blanks
If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(XlCellType.xlCellTypeBlanks).EntireRow.Delete ' delete rows where referenced range is blank
End With
End Sub
which will also delete rows whose column B content is blank
Related
This is a code that goes through the cells in column B in sheet2. If it finds a value that is not a date in column B, then it copies it, pastes it another sheet called 'errors' and then deletes that row from Sheet2. Whenever I try to run this, however, I get a 'Compile Error: Sub or function not defined'. I saw some other posts on this, but nothing mentioned there seemed to work for me.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheet("Errors").CountA("A1:A100")
For Each i In Worksheet("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheet("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
There are a few other errors/changes that could be made within the script
Add s to Worksheet
Use Option Explicit at top of code
Application.WorksheetFunction.CountA
Add range as argument to Counta i.e. Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Ensure correct ranges being worked with by wrapping in With Worksheets("Sheet2")
Determine last row by coming up from bottom of sheet with .Cells(.Rows.Count, "A").End(xlUp).Row, or you could end up looping to bottom of sheet
Correct syntax for delete line: i.EntireRow.Delete
You can put copy paste on one line: .Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
Be wary of using End(xlToRight) in cases of potentially ending up at far right of sheet.
Optimize code by switching some things off e.g. prevent repaint by switching off screen-updating during looping
Gather ranges to delete with Union and delete in 1 go or loop backwards to delete
VBA:
Option Explicit
Public Sub removeerrors()
Dim i As Range, x As Double, loopRange As Range, lastRow As Long, unionRng As Range
x = Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Application.ScreenUpdating = False
With Worksheets("Sheet2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set loopRange = .Range("A2:A" & lastRow)
If lastRow = 1 Then Exit Sub
For Each i In loopRange
If Not IsDate(i.Offset(0, 1)) Then
.Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, i)
Else
Set unionRng = i
End If
End If
Next i
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
You just need to change Worksheet to Worksheets with 's' at the end.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
For Each i In Worksheets("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheets("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub
use fully qualified range references
loop backwards when deleting rows
update target sheet pasting row index
as follows
Option Explicit
Sub removeerrors()
Dim iRow As Long
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
With Worksheets("Sheet2") ' referecne "Sheet2" sheet
With .Range(.Range("A2"), .Range("A2").End(xlDown)) ' reference referenced sheet range from cell A2 down to next not empty one
For iRow = .Rows.Count To 1 Step -1 ' loop reference range backwards from its last row up
If Not IsDate(.Cells(iRow, 2)) Then ' if referenced range cell in column B current row is not a date
.Range(.Cells(iRow, 1), .Cells(iRow, 1).End(xlToRight)).Copy Destination:=Worksheets("Errors").Range("A1").Offset(x, 0) ' copy referenced range current row spanning from column A to next not empty column and paste it to sheet "Errors" column A row x
x = x + 1 ' update offset
.Rows(1).EntireRow.Delete ' delete referenced range current row
End If
Next
End With
End With
End Sub
I have a excel which has multiple rows and columns and range of column values differ for each row.
Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.
Tried the below script:
Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range
Set sh = ThisWorkbook.Sheets("Sheet1")
Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))
For Each ID In IDS
Dim b As Integer
Dim k As Integer
k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
b = k - 1
range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
Selection.ClearContents
Next ID
End Sub
This is a little different approach but should help.
Also, it is generally not best to declare variables in a loop as you do with b & k just fyi
Sub test()
Dim sh As Worksheet
Dim row As Integer
Dim lastCol As Integer
Set sh = ThisWorkbook.Sheets("Sheet1")
For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row
lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column
sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents
Next
End Sub
Best of luck
I'd go as follows:
Sub test()
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
If .Count > 2 Then ' if referenced range has more then 2 cells
cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
.Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
End If
End With
Next
End With
End Sub
You can use Range.Delete Method (Excel)
range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft
I wrote a code to copy Column D, H, M and paste it on a brand new sheet starting from A-C. I first find the last row , after that I Union the 3 column range together then select the sheet and paste it.
For some reason I don't understand why it does not work. I have never used Union range before so not sure if that is the problem, or if it is something like my for loop. Help would be appreciated.
Dim ws As Worksheet
Dim lastRow As Integer
'for loop variables
Dim transCounter As Integer
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Dim multipleRange As Range
Dim lastRow1 As Integer
Dim ittercell As Integer
Set ws = ActiveSheet
For transCounter = 1 To 10
r.AutoFilter Field:=6, Criteria1:=transCounter.Value, Operator:=xlFilterValues
With Application.ActiveSheet
lastRow1 = .Cells(.Rows.Count, "AE").End(xlUp).Row
End With
Set range1 = Sheets("Sheet1").Range("D6:D" & lastRow1).SpecialCells(xlCellTypeVisible)
Set range2 = Sheets("Sheet1").Range("H6:I" & lastRow1).SpecialCells(xlCellTypeVisible)
Set range3 = Sheets("Sheet1").Range("M6:M" & lastRow1).SpecialCells(xlCellTypeVisible)
Set multipleRange = Union(range1, range2, range3)
multipleRange.Copy
Sheets("O1 Filteration").Select
'Range("A3").Select
'Range("A3").PasteSpecial xlPasteValues
ittercell = 1
Cells(3, ittercell).PasteSpecial xlPasteValues
ittercell = ittercell + 6
Next transCounter
There's a couple of issues with your code that might be causing the fault:
r is not defined in your code
use of transCounter.Value instead of just CStr(transCounter) (see #QHarr comment)
iterCell reset every iteration of the loop (see #QHarr comment)
Combination of ActiveSheet, unqualified Cells(... and manual Select on sheets makes the Range qualifications ambiguous
However, I do think the main logic of using Union, then Copy, then PasteSpecial is OK and just some tweaking is required.
Here is some working code where you update the Worksheet and Range references with your own. Please follow the comments.
Option Explicit
Sub CopyUnionColumns()
Dim wsSource As Worksheet '<-- Sheet1 in your code
Dim wsTarget As Worksheet '<-- O1 Filteration in your code
Dim rngFilter As Range '<-- main data range on Sheet1
Dim rngSource As Range '<-- to hold Union'd data after filtering
Dim rngTarget As Range '<-- range in O1 Filteration to paste code to
Dim lngLastRow As Long '<-- last row of main data
Dim lngCounter As Long '<-- loop variable
Dim lngPasteOffsetCol As Long '<-- offset column for pasting in the loop
' set references to source and target worksheets
Set wsSource = ThisWorkbook.Worksheets("Sheet2") '<-- update for your workbook
Set wsTarget = ThisWorkbook.Worksheets("Sheet3") '<-- update for your workbook
' set reference to data for filtering in source worksheet
lngLastRow = wsSource.Cells(wsSource.Rows.Count, 6).End(xlUp).Row
Set rngFilter = wsSource.Range("A1:F" & lngLastRow)
' initialise offset column
lngPasteOffsetCol = 0
' iterate rows
For lngCounter = 1 To 10
' filter data the data per the counter
rngFilter.AutoFilter Field:=6, Criteria1:=CStr(lngCounter), Operator:=xlFilterValues
' set source range as union of columnar data per last row
Set rngSource = Application.Union( _
wsSource.Range("A1:A" & lngLastRow).SpecialCells(xlCellTypeVisible), _
wsSource.Range("C1:C" & lngLastRow).SpecialCells(xlCellTypeVisible), _
wsSource.Range("E1:E" & lngLastRow).SpecialCells(xlCellTypeVisible))
' set target range on target sheet top left cell and offset column
Set rngTarget = wsTarget.Range("A1").Offset(0, lngPasteOffsetCol)
' copy source cells
rngSource.Copy
' paste to target
rngTarget.PasteSpecial Paste:=xlPasteAll
' increment offset
lngPasteOffsetCol = lngPasteOffsetCol + 6
Next lngCounter
' cancel cut copy mode
Application.CutCopyMode = False
' cancel autofilter
wsSource.AutoFilterMode = False
End Sub
I am banging my head to find a way to delete filtered/hidden rows from a ListObject table.
The filtering is not performed trough the code, it's performed by the user using the table header filters. I want to remove the filtered/hidden rows before unlisting the ListObject Table and perform Subtotal operation. If I don't delete the filtered/hidden rows before unlisting the Table, these rows reappear.
Current Code :
Sub SubTotalParClassification(ReportSheetTitle)
Dim ws As Worksheet
Dim drng As Range
Endcol = ColCalculationEndIndex
Set ws = Sheets(ReportSheetTitle)
'CODE TO REMOVE HIDDEN/FILTERED ROWS
Set lo = ActiveSheet.ListObjects("Entrée")
For i = 1 To lo.ListRows.Count Step 1
If Rows(lo.ListRows(i).Range.Row).Hidden = True Then
lo.ListRows(i).Delete
Next
' convert the table back to a range to be able to build subtotal
ws.ListObjects("Entrée").Unlist
With ws
'Select range to Subtotal
Set drng = .Range(.Cells(REPORTHEADERROW, REPORTSSTARTCOL), .Cells(EndRow, Endcol))
'apply Excel SubTotal function
.Cells.RemoveSubtotal
drng.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(Endcol - 6, Endcol - 5, Endcol - 4, Endcol - 3, Endcol - 2, Endcol - 1)
End With
'Update EndRow
EndRow = ActiveSheet.Cells(Rows.Count, REPORTSSTARTCOL).End(xlUp).Row
End Sub
Unfortunately, the Range.SpecialCells method does not have a specific parameter for xlCellTypeInvisible, only one for xlCellTypeVisible. To collect all of the hidden rows we need to find the compliment of the .DataBodyRange property and the visible rows, not the Intersect. A short UDF can take care of that.
Once a Union of the hidden rows have been established you cannot simply delete the rows; you must cycle through the Range.Areas property. Each area will contain one or more contiguous rows and those can be deleted.
Option Explicit
Sub wqewret()
SubTotalParClassification "Sheet3"
End Sub
Sub SubTotalParClassification(ReportSheetTitle)
Dim a As Long, delrng As Range
With Worksheets(ReportSheetTitle)
With .ListObjects("Entrée")
'get the compliment of databody range and visible cells
Set delrng = complimentRange(.DataBodyRange, .DataBodyRange.SpecialCells(xlCellTypeVisible))
Debug.Print delrng.Address(0, 0)
'got the invisible cells, loop through the areas backwards to delete
For a = delrng.Areas.Count To 1 Step -1
delrng.Areas(a).EntireRow.Delete
Next a
End With
End With
End Sub
Function complimentRange(bdyrng As Range, visrng As Range)
Dim rng As Range, invisrng As Range
For Each rng In bdyrng.Columns(1).Cells
If Intersect(visrng, rng) Is Nothing Then
If invisrng Is Nothing Then
Set invisrng = rng
Else
Set invisrng = Union(invisrng, rng)
End If
End If
Next rng
Set complimentRange = invisrng
End Function
Remember that it is considered 'best practise' to start at the bottom and work towards the top when deleting rows.
I have an excel which has 3 sheets. In sheet 1 and 2 i have approximately 10 columns each but has different total number of rows. I want to check if data in Sheet 2 is in Sheet 1. If it has a match then do nothing but if it has no match then copy the entire row into sheet 3.
Here's my code But I think i got it wrong
Sub test()
Dim rng As Range, c As Range, cfind As Range
On Error Resume Next
Worksheets("sheet3").Cells.Clear
With Worksheets("sheet1")
Set rng = Range(.Range("A2"), .Range("a2").End(xlDown))
For Each c In rng
With Worksheets("sheet2")
Set cfind = .Columns("A:A").Cells.Find _
(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then GoTo line1
'c.EntireRow.Copy Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
c.Copy Worksheets("sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
c.Offset(0, 2).Copy Worksheets("sheet3").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
End With 'sheet 2
line1:
Next c
Application.CutCopyMode = False
End With 'sheet 1
To explain it in picture refer below
Sheet 1
Sheet 2
Sheet 3
The Sheet 3 is my expected output. Can i obtain the output such as that.
Please help.
Thanks.
Try this one "
Sub test()
Dim rng As Range, c As Range, cfind As Range
On Error Resume Next
Worksheets(3).Cells.Clear
With Worksheets(1)
Set rng = .Range(.Range("A2"), .Range("a2").End(xlDown)) 'added . (dot) in front of first range
For Each c In rng
With Worksheets(2)
Set cfind = .Columns("A:A").Cells.Find _
(what:=c.Value, lookat:=xlWhole)
If cfind Is Nothing Then
'change the "10" in "Resize(1, 10)" to the number of columns you have
c.Resize(1, 10).Copy Worksheets(3).Cells(Worksheets(3).Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
End With 'sheet 2
Next c
Application.CutCopyMode = False
End With 'sheet 1
End Sub
Edit for Avidan's question in comments
To check every row with every row on other sheet requires different approach. Such as :
Sub CopyMissingRecords()
'compare whole record in row on 1st worksheet with all records in rows on 2nd worksheet
'and if there is no such row in the 2nd worksheet, then copy the missing record to 3rd worksheet
'repeat for all records on 1st worksheet
Dim varToCopy() As Variant
Dim varToCompare() As Variant
Dim intCopyRow As Integer
Dim intCopyRowMax As Integer
Dim intToCompareRow As Integer
Dim intToCompareRowMax As Integer
Dim bytColumnsInData As Byte
Dim intMisMatchCounter As Integer
Dim intComparingLoop As Integer
Dim intRowMisMatch As Integer
bytColumnsInData = 10 ' change to your situation
'clear everything in our output columns in Worksheets(3)
With Worksheets(3)
.Range(.Cells(2, 1), .Cells(.Rows.Count, bytColumnsInData)).Clear
End With
With Worksheets(1)
'last row in Worksheets(1)
intCopyRowMax = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
'compare each row in Worksheets(1)
For intCopyRow = 2 To intCopyRowMax
'store the first row record from Worksheets(1) into memory
ReDim varToCopy(0)
varToCopy(0) = .Range(.Cells(intCopyRow, 1), .Cells(intCopyRow, bytColumnsInData))
With Worksheets(2)
'last row in Worksheets(2)
intToCompareRowMax = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
'loop through all rows in Worksheets(2)
For intToCompareRow = 2 To intToCompareRowMax
'store the actual row record from Worksheets(2) into memory
ReDim varToCompare(0)
varToCompare(0) = .Range(.Cells(intToCompareRow, 1), .Cells(intToCompareRow, bytColumnsInData))
'compare each column from the row record in Worksheets(1), with each column from the row record in Worksheets(2)
For intComparingLoop = 1 To bytColumnsInData
'if any of the cells from Worksheets(1) in compared row are different than cells from Worksheets(2) in compared row
'just one difference in row is enough to consider this record as missing
If varToCopy(0)(1, intComparingLoop) <> varToCompare(0)(1, intComparingLoop) Then
'store how many row MisMatches are there in data
intRowMisMatch = intRowMisMatch + 1
Exit For
End If
Next intComparingLoop
Next intToCompareRow 'next row in Worksheets(2)
'if there are as many row mismatches as there are row records in Worksheets(2)
If intRowMisMatch = intToCompareRowMax - 1 Then
With Worksheets(3)
'copy the entire row from Worksheets(1) to the next available row in Worksheets(3)
Worksheets(1).Range(Worksheets(1).Cells(intCopyRow, 1), Worksheets(1).Cells(intCopyRow, bytColumnsInData)).Copy _
Destination:=.Cells(.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With 'Worksheets(3)
End If
'reset the counter
intRowMisMatch = 0
End With 'Worksheets(2)
Next intCopyRow 'next row in Worksheets(1)
End With 'Worksheets(1)
End Sub