delete rows based on criteria in multiple sheets - excel

I used this code to look for the words written in in Cell (10,2) in different rows of table in multiple Sheets in the same workbook, and when found the word, the code will delete the entire row in each table, the issue is that the code is applied in the first sheet where the command button is on and not applied on other sheets, so please your help in this.
sub Deletrows_Click()
Dim WS As Worksheet
Dim pattern As String
For Each WS In ThisWorkbook.Worksheets
With WS
pattern = Cells(10, 2) ' delete row if found the word total in it
RowCount = ActiveSheet.UsedRange.Rows.Count
Dim i As Integer
For i = 2 To RowCount
Dim j As Integer
For j = 1 To 3 'find the word within this range
If Cells(i, j) = pattern Then
Cells(i, j).EntireRow.Delete
End If
Next j
Next i
End With
Next WS
End Sub

You need to fully qualify all your Range and Cells inside the With WS statement, by adding the . as a prefix.
E.g. instead of pattern = Cells(10, 2) use pattern = .Cells(10, 2) , the .Cells(10, 2) means Cells(10, 2) of WS , which is being advanced in your For Each WS In ThisWorkbook.Worksheets.
Code
Option Explicit
Sub Deletrows_Click()
Dim WS As Worksheet
Dim pattern As String
Dim RowCount As Long, i As Long, j As Long
For Each WS In ThisWorkbook.Worksheets
With WS
pattern = .Cells(10, 2) ' delete row if found the word total in it
RowCount = .UsedRange.Rows.Count
For i = 2 To RowCount
For j = 1 To 3 'find the word within this range
If .Cells(i, j) = pattern Then
.Cells(i, j).EntireRow.Delete
End If
Next j
Next i
End With
Next WS
End Sub
Option 2: Instead of using two For loops, you could replace the 2nd For loop with the Application.Match function, to look for a certain value throughout the row.
Code with Match
Option Explicit
Sub Deletrows_Click()
Dim WS As Worksheet
Dim pattern As String
Dim RowCount As Long, i As Long, j As Long
For Each WS In ThisWorkbook.Worksheets
With WS
pattern = .Cells(10, 2) ' delete row if found the word total in it
RowCount = .UsedRange.Rows.Count
For i = 2 To RowCount
' use the Match function to find the word inside a certain row
If Not IsError(Application.Match(pattern, .Range(.Cells(i, 1), .Cells(i, 3)), 0)) Then '<-- match was successful
.Cells(i, 1).EntireRow.Delete
End If
Next i
End With
Next WS
End Sub
Edit 2:
Option Explicit
Sub Deletrows_Click()
Dim WS As Worksheet
Dim pattern As String
Dim FirstRow As Long, RowCount As Long, i As Long, j As Long
Dim FirstCol, ColCount As Long
For Each WS In ThisWorkbook.Worksheets
With WS
pattern = .Cells(10, 2) ' delete row if found the word total in it
FirstRow = .UsedRange.Row
RowCount = .UsedRange.Rows.Count
FirstCol = .UsedRange.Column
ColCount = .UsedRange.Columns.Count
For i = 2 To RowCount + FirstRow
' use the Match function to find the word inside a certain row
If Not IsError(Application.Match(pattern, .Range(.Cells(i, 1), .Cells(i, ColCount + FirstCol)), 0)) Then '<-- match was successful
.Cells(i, 1).EntireRow.Delete
End If
Next i
End With
Next WS
End Sub

Sub Deletrows_Click()
Dim WS As Worksheet
Dim pattern As String
Dim FirstRow As Long, RowCount As Long, i As Long, j As Long
Dim FirstCol, ColCount As Long
For Each WS In ThisWorkbook.Worksheets
With WS
pattern = Sheets("Sheet1").Cells(10, 2) ' delete row if found the word in this source sheet
FirstRow = .UsedRange.Row
RowCount = .UsedRange.Rows.Count
FirstCol = .UsedRange.Column
ColCount = .UsedRange.Columns.Count
For i = 2 To RowCount + FirstRow
' use the Match function to find the word inside a certain row
If WS.Name <> "Sheet1" Then 'I added this to exclude the said sheet as a source page
If Not IsError(Application.Match(pattern, .Range(.Cells(i, 1), .Cells(i, ColCount + FirstCol)), 0)) Then '<-- match was successful
.Cells(i, 1).EntireRow.Delete
End If
End If
Next i
End With
Next WS
End Sub

Related

How can we compare two columns and copy differences from Sheet2 to Sheet1?

I have two ranges on two sheets.
I am trying to compare these two lists for differences, and copy any differences from Sheet2 to Sheet1. Here is my code. I think it's close, but something is off, because all if does is delete row 14 on Sheet1 and no different cells from Sheet2 are copied to Sheet1. What's wrong here?
Sub Compare()
Dim lastRow1 As Integer
Dim lastRow2 As Integer
Dim foundTrue As Boolean
lastRow1 = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
lastRow2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "E").End(xlUp).Row
For i = 2 To lastRow2
foundTrue = False
For j = 2 To lastRow1
If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then
foundTrue = True
Exit For
End If
Next j
If Not foundTrue Then
Sheets("Sheet2").Cells(i).Copy Destination:=Sheets("Sheet1").Rows(lastRow1 - 1)
End If
Next i
Debug.Print i
End Sub
I want to end up with this.
Nothing that a debug session can't reveal.
You need to copy to lastrow + 1, not lastrow - 1.
After copying the first value, you need to somehow increase the value for lastRow1. But as you use this value as limit in your (inner) for-loop, you shouldn't modify it. So I suggest you introduce a counter variable that counts how many rows you already copied and use this as offset.
And you have some more mistakes:
Your data in sheet2 is in columns E and F, but you compare the values of column "A" (you wrote Sheets("Sheet2").Cells(i, 1).Value)
The source in your copy-command accesses is .Cells(i). In case i is 10, this would be the 10th cell of your sheet, that is J1 - not the cell E10. And even if it was the correct cell, you would copy only one cell, not two.
Obgligatory extra hints: Use Option Explicit (your variables i and j are not declared), and always use Long, not Integer.
Code could look like (I renamed foundTrue because it hurts my eyes to see True in a variable name)
Dim i As Long, j As Long
For i = 2 To lastRow2
foundValue = False
For j = 2 To lastRow1
If Sheets("Sheet2").Cells(i, 5).Value = Sheets("Sheet1").Cells(j, 1).Value Then
foundValue = True
Exit For
End If
Next j
If Not foundValue Then
addedRows = addedRows + 1
Sheets("Sheet2").Cells(i, 5).Resize(1, 2).Copy Destination:=Sheets("Sheet1").Cells(lastRow1, 1).Offset(addedRows)
End If
Next i
But this leaves a lot room for improvement. I suggest you have a look to the following, in my eyes it's much cleaner and much more easy to adapt. There is still room for optimization (for example read the data into arrays to speed up execution), but that's a different story.
Sub Compare()
Const sourceCol = "E"
Const destCol = "A"
Const colCount = 2
' Set worksheets
Dim sourceWs As Worksheet, destWs As Worksheet
Set sourceWs = ThisWorkbook.Sheets("Sheet2")
Set destWs = ThisWorkbook.Sheets("Sheet1")
' Count rows
Dim lastRowSource As Long, lastRowDest As Long
lastRowSource = sourceWs.Cells(sourceWs.Rows.Count, sourceCol).End(xlUp).Row
lastRowDest = destWs.Cells(destWs.Rows.Count, destCol).End(xlUp).Row
Dim sourceRow As Long, destRow As Long
Dim addedRows As Long
For sourceRow = 2 To lastRowSource
Dim foundValue As Boolean
foundValue = False
For destRow = 2 To lastRowDest
If sourceWs.Cells(sourceRow, sourceCol).Value = destWs.Cells(destRow, destCol).Value Then
foundValue = True
Exit For
End If
Next destRow
If Not foundValue Then
addedRows = addedRows + 1
sourceWs.Cells(sourceRow, sourceCol).Resize(1, colCount).Copy Destination:=destWs.Cells(lastRowDest, 1).Offset(addedRows)
End If
Next sourceRow
End Sub
Copy Differences (Loop)
A Quick Fix
Option Explicit
Sub Compare()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws1 As Worksheet: Set ws1 = wb.Worksheets("Sheet1")
Dim lRow1 As Long: lRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Dim fRow1 As Long: fRow1 = lRow1
Dim ws2 As Worksheet: Set ws2 = wb.Worksheets("Sheet2")
Dim lRow2 As Long: lRow2 = ws2.Cells(ws2.Rows.Count, "E").End(xlUp).Row
Dim i As Long, j As Long
For i = 2 To lRow2
For j = 2 To lRow1
If ws2.Cells(i, "E").Value = ws1.Cells(j, "A").Value Then Exit For
Next j
' Note this possibility utilizing the behavior of the For...Next loop.
' No boolean necessary.
If j > lRow1 Then ' not found
fRow1 = fRow1 + 1
ws2.Cells(i, "E").Resize(, 2).Copy ws1.Cells(fRow1, "A")
End If
Next i
MsgBox "Found " & fRow1 - lRow1 & " differences.", vbInformation
End Sub

VBA. Deleting multiple cells in a row if one cell is blank

I have multiple columns in an excel sheet...say A1:D10.
I want to find any blank cells in column C, delete that cell as well as the A,B, and D cells of that same row, then shift up. But only in the range of A1:D10. I have other information in this excel sheet outside this range that I want to perserve in its original position. Therefore I can not use somthing like this:
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Nor can I get something like the following to work, because it only shifts the single column up, not all four columns.
Set rng = Range("A1:D10").SpecialCells(xlCellTypeBlanks)
rng.Rows.Delete Shift:=xlShiftUp
If there is no data in columns A to D below row 10 that you don't want to move up, then SpecialCells and Delete Shift Up can be used like this
Sub Demo1()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
Dim rng As Range, arr As Range
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
On Error Resume Next
Set rng = .Range(.Cells(FirstRow, TestColumn), .Cells(LastRow, TestColumn)).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
For Each arr In rng.Areas
arr.EntireRow.Resize(, EndColumn - StartColumn + 1).Delete Shift:=xlShiftUp
Next
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
If there is data in columns A to D below row 10 that you don't want to move up, then you can use Cut and Paste, like this
Sub Demo()
Dim ws As Worksheet
Dim TestColumn As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long
' set up reference data
Set ws = ActiveSheet '<~~ update as required
TestColumn = 3 'C
StartColumn = 1 'A
EndColumn = 4 'D
FirstRow = 1
LastRow = 10
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
If IsEmpty(.Cells(LastRow, TestColumn)) Then
.Cells(LastRow, StartColumn).Resize(1, EndColumn - StartColumn + 1).Clear
End If
For i = LastRow - 1 To FirstRow Step -1
If IsEmpty(.Cells(i, TestColumn)) Then
.Range(.Cells(i + 1, StartColumn), .Cells(LastRow, EndColumn)).Cut .Cells(i, StartColumn)
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Using Variant Array Method
Sub test2()
Dim rngDB As Range, vDB As Variant
Dim i As Integer, j As Integer, n As Integer
Dim k As Integer
Set rngDB = Range("a1:d10")
vDB = rngDB
n = UBound(vDB, 1)
For i = 1 To n
If IsEmpty(vDB(i, 3)) Then
For j = 1 To 4
If j <> 3 Then
vDB(i, j) = Empty
End If
Next j
End If
Next i
For j = 1 To 4
If j <> 3 Then
For i = 1 To n - 1
For k = i To n - 1
If vDB(k, j) = Empty Then
vDB(k, j) = vDB(k + 1, j)
vDB(k + 1, j) = Empty
End If
Next k
Next i
End If
Next j
rngDB = vDB
End Sub
The below will take care of your requirement by looking for an empty cell in column 3, and deleting the row and shifting up only in that row.
Sub deleteEmptyRow()
Dim i As Integer
For i = 1 To 10
If Cells(i, 3) = "" Then
Range(Cells(i, 1), Cells(i, 4)).delete Shift:=xlUp
End If
Next i
End Sub

How to modify this code to only search visible rows and columns

I have a userform that allows the user to select which rows and columns are relevant to the user to check. I am using this code, but it searches all rows and all columns and therefore doesn't delete the right rows. Could anyone suggest a solution to fixing this that will work for rows and columns? Thanks.
Dim RowToTest As Long
Dim MySheet As Worksheet
Dim ProjectedDate As Date
Dim ColToTest As Long
Dim TempKeep As Integer
TempKeep = 0
ProjectedDate = Date + 60
For Each MySheet In ThisWorkbook.Sheets
For RowToTest = MySheet.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
For ColToTest = MySheet.Cells(2, Columns.Count).End(xlToLeft).Column To 15 Step -1
With MySheet.Cells(RowToTest, ColToTest)
If IsDate(MySheet.Cells(RowToTest, ColToTest).Value) Then
If .Value < ProjectedDate Then
TempKeep = 1
End If
End If
End With
Next ColToTest
If TempKeep = 0 Then
MySheet.Rows(RowToTest).EntireRow.Delete
End If
TempKeep = 0
Next RowToTest
Next
You can check if a cell is hidden through their .Rows and .Columns property like so:
If CelToCheck.Rows.Hidden or CelToCheck.Columns.Hidden Then
'Your code if hidden
Else
'Code if not hidden
End if
In your case CelToCheck would be
MySheet.Cells(RowToTest, ColToTest)
Alternatively you can set a range variable and loop through visible cells only with
For each CL in RangeVariable.SpecialCells(xlCellTypeVisible)
'Your code
Next CL
I was about to suggest the same as JvdV, using the .Hidden property. Can use it in your code something like this:
Dim RowToTest As Long
Dim MySheet As Worksheet
Dim ProjectedDate As Date
Dim ColToTest As Long
Dim TempKeep As Integer
TempKeep = 0
ProjectedDate = Date + 60
For Each MySheet In ThisWorkbook.Sheets
For RowToTest = MySheet.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
For ColToTest = MySheet.Cells(2, Columns.Count).End(xlToLeft).Column To 15 Step -1
With MySheet.Cells(RowToTest, ColToTest)
If IsDate(MySheet.Cells(RowToTest, ColToTest).Value) Then
If .Value < ProjectedDate Then
TempKeep = 1
End If
End If
End With
Next ColToTest
If TempKeep = 0 and Not isHiddenRow(MySheet, RowToTest) Then
MySheet.Rows(RowToTest).EntireRow.Delete
End If
TempKeep = 0
Next RowToTest
Next
don't necessarily need to have a function to do so, but makes it easier for code reuse.
Function isHiddenRow(sht As Worksheet, rowNr As Long) As Boolean
On Error Resume Next
isHiddenRow = sht.Rows(rowNr).Hidden
End Function
Function isHiddenCol(sht As Worksheet, colNr As Long) As Boolean
On Error Resume Next
isHiddenCol = sht.Columns(colNr).Hidden
End Function
PS: depending how much data you have in your sheet, is not a very good idea to loop directly over the sheet generally. Consider using arrays if you have thousands of rows.
EDIT: added an alternative using an array to do the same thing.
Option Explicit
Sub delVisibleRows()
Dim MySheet As Worksheet
Dim ProjectedDate As Date: ProjectedDate = Date + 60
Dim R As Long, C As Long, lRow As Long, lCol As Long
Dim arrData As Variant
Dim strRange As String
For Each MySheet In ThisWorkbook.Sheets 'for each sheet
With MySheet
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'get last row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column 'get last column
arrData = .Range(.Cells(1, 1), .Cells(lRow, lCol)) 'allocate the data to an array
For R = 2 To lRow 'iterate through all rows starting at 2
For C = 15 To lCol 'iterate through all columns, starting at 15 - this could cause a problem if there are less than 15 columns
If IsDate(arrData(R, C)) And arrData(R, C) < ProjectedDate Then 'check if is date, and if is less than projected date
Exit For 'if it is, skip to next row
End If
If C = lCol Then 'If we got to last col without meeting the skip condition
strRange = strRange & R & ":" & R & "," 'build the string for the range to delete
End If
Next C
Next R
strRange = Left(strRange, Len(strRange) - 1) 'get rid of the last comma
.Range(strRange).SpecialCells(xlCellTypeVisible).EntireRow.Delete 'delete only the visible rows
End With
Next MySheet
End Sub

VBA code to Insert a Column

I want to insert a column to the right if string"P018" is present in the third row of the sheet:
My code is :
Sub Insrt()
Dim Found As Range
Dim LR As Long
Dim I As Integer
I = 1
Do While Cells(4, I).Value <> ""
'If Cells(3, I).Value = "P018" Then
Set Found = Cells(3, I).Find(what:="P018", LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then GoTo Label
Found.Offset(, 1).EntireColumn.Insert
Label:
Loop
End Sub
This going in an endless loop.
You want to use a standard for loop that loops backwards:
Sub insert()
Dim ws As Worksheet
Dim lastColumn As Long
Dim i As Long
Set ws = ActiveSheet
With ws
lastColumn = .Cells(4, .Columns.Count).End(xlToLeft).Column
For i = lastColumn To 1 Step -1
If .Cells(3, i) = "P018" Then Columns(i + 1).insert
Next i
End With
End Sub

VBA Collection issue

I an trying towrite a simple VBA code where some cell values are combined.
Problem with code bellow is that Cell Object in the loop keeps selecting whole row, not just one cell in Row Collection
Dim Cell As Range
Dim Row As Range
Set Row = Rows(ActiveCell.Row)
Set Cell = ActiveCell
For Each Cell In Row
With Cell
If IsNumeric(InStr(1, Right(.Value, 1), "/")) Then
.Value = .Value & .Offset(0, 1).Value
.Offset(0, 1).Delete (xlShiftToLeft)
End If
End With
Next Cell
Try this. For this example, assumptions made about data being on Sheet1 and the start row (stRow) and start col (testCol) of the data. Amend these to suit your conditions.
Option Explicit
Sub combine()
Dim ws As Worksheet
Dim stRow As Long, endRow As Long, testCol As Long, endCol As Long
Dim rnum As Long, cnum As Long
Dim cl As Range
Set ws = Sheets("Sheet1")
stRow = 1
testCol = 1
With ws
endRow = .Cells(Rows.Count, testCol).End(xlUp).Row
For rnum = stRow To endRow
endCol = .Cells(rnum, Columns.Count).End(xlToLeft).Column
For cnum = testCol To endCol - 1
Set cl = .Cells(rnum, cnum)
If Right(cl, 1) = "/" And Right(cl.Offset(0, 1), 1) <> "/" Then
If IsNumeric(Left(cl.Value, Len(cl.Value) - 1)) Then
cl.Value = cl.Value & cl.Offset(0, 1).Value
cl.Offset(0, 1).Delete (xlShiftToLeft)
End If
End If
Next cnum
Next rnum
End With
End Sub
Although not specified by you, this code does not combine an adjacent cell which also has a trailing "/". This on the basis that we shouldn't 'remove' a 'test' value. If this condition not required it is easily changed.

Resources