I have the following which I am using to remove all rows of data where the name in column DX is not a specified name. The code will sort through all rows and delete each row that doesn't contain that specific name. The problem is, it is way too slow.
Any thoughts?
Sub DeleteNonName()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 2
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "DX")
If Not IsError(.Value) Then
If InStr(.Value, "Name") = 0 Then .EntireRow.Delete
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
Sub DeleteName()
With ActiveSheet
.AutoFilterMode = False
With Range("DX1", Range("DX" & Rows.Count).End(xlUp))
.AutoFilter 1, "Name"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
Selection.AutoFilter
End Sub
Related
I found on this website a macro to delete row if a specific value exists:
https://www.rondebruin.nl/win/s4/win001.htm
I am trying to modify a bit this code in order to be able to enter not only manually:
• the column on which I want to do the modification (for example A)
• but also the string I want to delete.
That´s why I added manually the following datas in the code:
Dim Columnname As String
Dim DeleteStr As String
Columnname = Application.InputBox("Select Column", xTitleId, Type:=2)
DeleteStr = Application.InputBox("Delete Text", xTitleId, Type:=2)
With .Cells(Lrow, " & Columnname & ")
If .Value = " & DeleteStr & " Then .EntireRow.Delete
The problem that I have when I run the code: I come across a windows which comes up “Run-time error 13” Type mismatch…Indeed it seems there is mismatch error on the line :
With .Cells(Lrow, " & Columnname & ")
Unfortunately, I do not manage to identify where the mistake comes from. That would be fantastic if someone could help me.
Thank you so much in advance.
Xavi
Here below, please find my Code:
Sub Loop_Example()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim Columnname As String
Dim DeleteStr As String
Columnname = Application.InputBox("Select Column", xTitleId, Type:=2)
DeleteStr = Application.InputBox("Delete Text", xTitleId, Type:=2)
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With ActiveSheet
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = Lastrow To Firstrow Step -1
'We check the values in the selected column in this example
With .Cells(Lrow, " & Columnname & ")
If Not IsError(.Value) Then
If .Value = " & DeleteStr & " Then .EntireRow.Delete
'This will delete each row with the Value "DeleteStr"
'in the seleted Column, case sensitive.
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
It's much easier to delete the rows with autofilter rather than using loops.
Sub test()
Dim Columnname As String
Dim DeleteStr As String
Columnname = Application.InputBox("Select Column", xTitleId, Type:=2)
DeleteStr = Application.InputBox("Delete Text", xTitleId, Type:=2)
With ActiveSheet
.AutoFilterMode = False
With .Range(Columnname & "1", .Range(Columnname & Rows.Count).End(xlUp))
.AutoFilter 1, DeleteStr
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End Sub
You don't need quotes around your variables:
'...
With .Cells(Lrow, Columnname)
If Not IsError(.Value) Then
If .Value = DeleteStr Then .EntireRow.Delete
'This will delete each row with the Value "DeleteStr"
'in the seleted Column, case sensitive.
End If
End With
'...
It is more efficient to delete in one go with Union of the qualifying ranges. And to loop only the necessary number of rows use the chosen column to determine the last row to determinate looping at. You can also re-write to use an efficient For Each Loop over the collection by setting a variable to hold your cells to loop over and using a For Each on that.
Option Explicit
Public Sub Loop_Example()
Dim Firstrow As Long, Lastrow As Long, Lrow As Long, CalcMode As Long, ViewMode As Long, Columnname As String
Dim DeleteStr As String, unionRng As Range, rng As Range
Columnname = Application.InputBox("Select Column", , Type:=2)
DeleteStr = Application.InputBox("Delete Text", , Type:=2)
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Activate
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .Cells(.Rows.Count, Columnname).End(xlUp).Row
Dim loopRange As Range: Set loopRange = .Range("C" & Firstrow & ":" & "C" & Lastrow)
For Each rng In loopRange
If rng.Value = DeleteStr Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, rng)
Else
Set unionRng = rng
End If
End If
Next
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
End Sub
I currently have a macro that formats an excel file. I was curious if there was a way to have this format all sheets that contain a specific text in the title. I'll have a workbook with numerous tab for various companies with a little different formatting requirements for each company and some months a few companies will be different. If the sheets don't exist, then ignore and move on..... Any help would be greatly appreciated.
Worksheets("DEN BS Assets").Select
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 12
Columns("A:A").Select
Selection.Replace What:="X", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 9
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
Select Case .Value
Case Is = "Denver", "Inactive", "System:": .EntireRow.Delete
End Select
End If
End With
Next Lrow
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 7
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
Select Case .Value
Case Is = "Net Change", "Account:": .EntireRow.Insert
End Select
End If
End With
Next Lrow
End With
With ActiveSheet.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 7
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
Select Case .Value
Case Is = "Net Change", "Totals:": .EntireRow.Delete
End Select
End If
End With
Next Lrow
End With
Range("A50000").Select
Selection.End(xlUp).Offset(-1, 0).Select
Selection.Insert Shift:=xlToRight
Selection.EntireRow.Insert
Range("A50000").Select
Selection.End(xlUp).Offset(-1, 0).Select
Selection.Insert Shift:=xlToRight
Range("A50000").Select
Selection.End(xlUp).Offset(0, 0).Select
Selection.Insert Shift:=xlToRight
Columns("F").ColumnWidth = 20
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Rows("9:9").Select
ActiveWindow.FreezePanes = True`
I have made some changes to your code, remove some unnecessary Select statements (although not all as wasn't sure what the end section does). Also don't think you need two loops to insert and then delete rows.
Sub x()
Dim ws As Worksheet
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each ws In Worksheets
If ws.Name Like "Denver*" Then
ws.Cells.EntireColumn.AutoFit
ws.Columns("A:A").ColumnWidth = 12
ws.Columns("A:A").Replace What:="X", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
With ws
.DisplayPageBreaks = False
Firstrow = 9
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
Select Case .Value
Case Is = "Denver", "Inactive", "System:": .EntireRow.Delete
End Select
End If
End With
Next Lrow
End With
With ws
Firstrow = 7
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
Select Case .Value
Case Is = "Net Change", "Account:": .EntireRow.Insert
End Select
End If
End With
Next Lrow
End With
With ws
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
Select Case .Value
Case Is = "Net Change", "Totals:": .EntireRow.Delete
End Select
End If
End With
Next Lrow
End With
ws.Range("A50000").End(xlUp).Offset(-1, 0).Resize(, 2).Insert shift:=xlToRight
ws.Range("A50000").End(xlUp).Offset(-1, 0).EntireRow.Insert
ws.Range("A50000").End(xlUp).Insert shift:=xlToRight
ws.Columns("F").ColumnWidth = 20
With ws.PageSetup
.PrintTitleRows = "$1:$8"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
ws.Rows("9:9").Select
ActiveWindow.FreezePanes = True
End If
Next ws
End Sub
I have my data all on one sheet ("PBT"). There are different ranges of data that need to go to different sheets. My current code will move the data to the sheet I want; however, it starts putting the data into A4 and then puts the next row into A3, A2, and then deletes anything else. I'd like it to go down from A4 and I'm not sure what I am doing wrong.
Here is the code:
Sub Move_Data()
'Moves data to set worksheets
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With Sheets("PBT")
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = Lastrow To Firstrow Step -1
'We check the values in the A column in this example
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
If Right(.Value, 7) >= 30001 And Right(.Value, 7) <= 32500 Then .EntireRow.Cut Sheets("WTH").Range("A4").End(xlUp).Offset(1)
'in Column A, case sensitive.
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
Try This. Your For Loop was going backwards from the last row to the first row. I took out the Step - 1 to make it increase instead of decrease and I flipped around the Firstrow and Lastrow so it starts on the first row and stops on the Lastrow.
Initial State of Sheet1: (Sheet2 is blank)
State of Sheet1 after code:
State of Sheet2 after code:
Sub Move_Data()
'Moves data to set worksheets
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim num_of_entries As Integer
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
num_of_entries = 0
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With Sheets("Sheet1")
'We select the sheet so we can change the window view
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
'Turn off Page Breaks, we do this for speed
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = Firstrow To Lastrow
'We check the values in the A column in this example
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
If Right(.Value, 7) >= 30001 And Right(.Value, 7) <= 32500 Then
.EntireRow.Cut Sheets("Sheet2").Range("A4").Offset(num_of_entries)
num_of_entries = num_of_entries + 1
'in Column A, case sensitive.
End If
End If
End With
Next Lrow
End With
'ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
Here is a version of the code that could solve some issues.
1. Go forward through the loop so you know where the write the values in the other sheet
2. By going forward you have to make sure to stay on the same row whenever you cut a row out, and not to go beyond the end of the now shorter list.
I marked the lines I changed with ***** in the comments.
Sub Move_Data()
'Moves data to set worksheets
'**** We dont need Firstrow anymore
'**** Dim Firstrow As Long
'**** Use Targetrow for driving where the move should be to
Dim TargetRow as Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With Sheets("PBT")
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
'**** Assign to Lrow as we will use While loop
Lrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'**** New variable for reference in target sheet
TargetRow = 5
' ***** We loop forward now
Do While Lrow <= Lastrow
'We check the values in the A column in this example
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
If Right(.Value, 7) >= 30001 And Right(.Value, 7) <= 32500 Then
'in Column A, case sensitive.
' **** Use Target Row to determine destination range
.EntireRow.Cut Sheets("WTH").Range("A" & TargetRow)
' **** increment the target row for next move.
TargetRow = TargetRow + 1
' **** As we removed one row, our last row is one less now
Lastrow = Lastrow - 1
' *** Counter the increment to the row, as we have the new
' *** row already at the position where we cut one away
Lrow = Lrow - 1
End If
End If
' **** Increment
Lrow = Lrow + 1
End With
'****
Loop
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
I have an Excel sheet with the following structure:
What I need to do is delete an entire record if either it's Type A or Type B are = 0. As an example, for record 1, I need to delete A & B because B = 0.
I have the following code:
Sub Loop_Example()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "B")
If Not IsError(.Value) Then
If .Value = "0" Then .EntireRow.Delete
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
Therefore, what I would like to do is add the logic to delete the entire row if the value is 0 and either the row above or below depending on its 'type'.
Thanks.
this should work.
Sub pDeleteRow()
Dim wksData As Worksheet
Dim rngCell As Range
Dim lngCounter As Long
Dim lngTotalCount As Long
Set wksData = Worksheets("Sheet1")
lngTotalCount = wksData.Range("A1").CurrentRegion.Rows.Count
lngCounter = 1
With wksData
While lngCounter <= lngTotalCount
If (UCase(Trim(.Cells(lngCounter, 2))) = "A" Or UCase(Trim(.Cells(lngCounter, 2))) = "B") And UCase(Trim(.Cells(lngCounter, 3))) = "0" Then
.Cells(lngCounter, 1).EntireRow.Delete
lngCounter = lngCounter - 1
lngTotalCount = lngTotalCount - 1
End If
lngCounter = lngCounter + 1
Wend
End With
End Sub
You can Try This:
Sub ConditionalRowDelete()
Set colA = Range("C1", Cells(Rows.Count, "C").End(xlUp))
Set colB = Range("D1", Cells(Rows.Count, "D").End(xlUp))
MsgBox colA.Rows.Count
For i = 1 To colA.Rows.Count
If colB(i) = 0 Then
If colA(i) = "A" Then
'colB(i).Select
With colB(i) 'Selection
Application.Union(.EntireRow, .Offset(1, 0).EntireRow).Delete 'Select
End With
'Selection.EntireRow.Select
'MsgBox "found A"
End If
If colA(i) = "B" Then
'colB(i).Select
With colB(i) 'Selection
Application.Union(.EntireRow, .Offset(-1, 0).EntireRow).Delete 'Select
End With
'MsgBox "found B"
End If
End If
Next
End Sub
I have a macro that highlights a row if there is anything blank text in a specific column. This macro is used to highlight areas where a user needs to direct attention. I want to be able to unhighlight those rows after changes have been made, by clicking the same macro button.
How do I do this?
This is the current macro:
Sub Macro13()
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 2
LastRow = .Cells(.Rows.Count, "M").End(xlUp).Row
For Lrow = LastRow To Firstrow Step -1
With .Cells(Lrow, "M")
If .Value = "" Then
.EntireRow.Interior.ColorIndex = 3
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
My idea was to, at the beginning of the macro, check to see if any row was highlighted red. If so, run a new loop that iterates through all columns, removing the cell highlighting, and then after that loop is done, break out of the macro. This is ugly and riddled with errors, though.
Sub Macro13() 'Checks for Incorrect Countries
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 2
LastRow = .Cells(.Rows.Count, "M").End(xlUp).Row
FirstrowA = 2
LastRowA = .Cells(.Rows.Count, "M").End(xlUp).Row
For Lrow = LastRow To Firstrow Step -1
With .Cells(Lrow, "M")
If .EntireRow.Interior.ColorIndex = 3 Then
For LrowA = LastRowA To FirstrowA Step -1
.EntireRow.Interior.ColorIndex = xlColorIndexNone
Next LrowA
End
Exit Sub
End If
If .Value = "" Then
.EntireRow.Interior.ColorIndex = 3
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
This should do the trick for you. I've added a loop that looks for any formatting before it starts highlighting blanks. If if finds something red, it clears the whole sheet of red formatting and raises a flag (Tracker = True). When the flag is raised, the macro will not
format blank cells' rows as red. I tested it and it worked for me.
Sub Macro13()
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = 2
LastRow = .Cells(.Rows.Count, "M").End(xlUp).Row
Dim Tracker As Boolean
Tracker = False
For Lrow = LastRow To Firstrow Step -1
If .Cells(Lrow, "M").EntireRow.Interior.ColorIndex = 3 Then
.Cells.Interior.ColorIndex = 0
Tracker = True
Exit For
End If
Next Lrow
If Tracker = False Then
For Lrow = LastRow To Firstrow Step -1
With .Cells(Lrow, "M")
If .Value = "" Then
.EntireRow.Interior.ColorIndex = 3
End If
End With
Next Lrow
End If
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
I've had a similar issue before and conditional formating didn't work well for me. I used something similar to this:
Sub CheckAndHighlight(area As Range, Optional ByVal searchValue As String = "")
Application.ScreenUpdating = False
Dim r As Range
For Each r In area
r.EntireRow.Interior.ColorIndex = 0
If r.Value = searchValue Then
r.EntireRow.Interior.ColorIndex = 3
End If
Next
Application.ScreenUpdating = True
End Sub