I am using VBA to delete rows that do not meet a certain criteria. The code is working, however, I can't figure out how to keep the blank rows separating the data. Below is the code I'm using. It works well for deleting what I want it to, however, it also is deleting the blank lines in between.
Sub DeleteRows()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
For i = Range("E" & Rows.Count).End(xlUp).Row To 1 Step -1
If (Range("E" & i).Value > -5 And Range("E" & i).Value < 5) Then
Range("E" & i).EntireRow.Delete
Else
If (Range("D" & i).Value > -500 And Range("D" & i).Value < 500) Then
Range("D" & i).EntireRow.Delete
End If
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thanks!
I think it should be enough to check for blank spaces and if a cell is blank, do not delete that row. Like this
Sub DeleteRows()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
For i = Range("E" & Rows.Count).End(xlUp).Row To 1 Step -1
If (Range("E" & i).Value > -5 And Range("E" & i).Value < 5 and Range("E" & i) <> "") Then
Range("E" & i).EntireRow.Delete
Else
If (Range("D" & i).Value > -500 And Range("D" & i).Value < 500 and Range("D" & i) <> "") Then
Range("D" & i).EntireRow.Delete
End If
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Adding another And statement should do the trick for example you can use <> to say Does Not Equal.
If (Range("E" & i).Value > -5 And Range("E" & i).Value < 5) And Range("E" & i).Value <> "" Then
Related
This is for an Microsoft Excel VBA macro. What it is supposed to do, for every row, when "Late" is entered into column C, to highlight the cell 2 spaces to the left and Range of cells 3 spaces to the right through 43. So example is C4 contains "Late", highlight A4 and F4:AW4. Same goes for the word "Hold" just a different color.
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i & ":AW" & i).ClearContents
.Range("F" & i & ":AW" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End With
End Sub
This should work for you...
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i & ":AW" & i).ClearContents
.Range("F" & i & ":AW" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End With
End Sub
Tested and seems to work fine for me :)
... C4 contains "Late" ... (emphasis mine)
This seems to indicate that Late may be part of a longer string. I will code to that effect.
Conditional formatting rules are a quick method of achieving your cell highlighting and respond as soon as values in column C change without rerunning the sub procedure (unless more values are added below the lastRow).
Option Explicit
Sub Macro1()
Const TEST_COLUMN As String = "D"
Dim lastRow As Long, sSheetName As String
sSheetName = ActiveSheet.Name
With Worksheets(sSheetName)
lastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
With .Range("A4:A" & lastRow & ", F4:AW" & lastRow)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=isnumber(search(""late"", $c4))"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 39
.FormatConditions.Add Type:=xlExpression, Formula1:="=isnumber(search(""hold"", $c4))"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 43
End With
End With
End Sub
Great! I wanted to run this in the worksheet and not as a module. So i added a few extra lines and ByVal Target As Range to fire everytime a change is made in the range but it doesn't seem to work. Am i missing something?
Private Sub Highlight_Condition(ByVal Target As Range)
Dim LastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = LastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i).EntireRow.Interior.ColorIndex = xlNone
End If
Next i
Application.EnableEvents = True
End With
End Sub
I am attempting to write some VBA that will accomplish
if row O is not null then copy all data to new row, then in current row clear columns I, J, K, L, M, N
in the newly inserted row clear columns O
The caveat I am not sure to account for is - throws a
Type mismatch error
Here is the syntax that I am trying to work with
Sub BlueBell()
Application.ScreenUpdating = False
Dim i As Long, y
ReDim y(2 To Range("A" & Rows.Count).End(3).Row)
For i = UBound(y) To LBound(y) Step -1
If Cells(i, "O") Then
If Cells(i, "I") = "" And Cells(i, "K") = "" And Cells(i, "M") = "" Then
GoTo DoNothing
Else
Rows(i).Copy
Cells(i, "A").Insert
Range("I" & i & ":J" & i & ":K" & i & ":L" & i & ":M" & i & ":N" & i & ":O" & i + 1).ClearContents
GoTo DoNothing
End If
End If
DoNothing:
Next i
End Sub
Apart from your error with using a string as a boolean expression, there are several things that can be changed in your code:
Sub BlueBell()
Application.ScreenUpdating = False
Dim i As Long ', y() As Variant
'ReDim y(2 To Range("A" & Rows.Count).End(3).Row) 'Why use an array?
For i = Range("A" & Rows.Count).End(3).Row To 2 Step -1
If Not IsEmpty(Cells(i, "O").Value) Then
'Avoid the use of GoTo
If Cells(i, "I").Value <> "" Or _
Cells(i, "K").Value <> "" Or _
Cells(i, "M").Value <> "" Then
Rows(i).Copy
Cells(i, "A").Insert
'Don't use a "Ix:Jx:Kx:Lx:Mx:Nx:Ox+1" range - it will lead to problems
'because even really experienced users don't understand what it does
Range("I" & i & ":N" & i).ClearContents
Range("O" & i + 1).ClearContents
End If
End If
Next i
'It's a good habit to reset anything that you disabled at the start of your code
Application.ScreenUpdating = True
End Sub
I'm trying to create a Macro that will modify contents in columns S, W and AH based on the content in AB
e.g. if AB1 = No, then S1=C-MEM, AH = N/A and W is cleared.
For some reason, I get a 'Type mismatch' error on the first line of my if statement and can't figure out why or how to fix it - even after reading other posts about similar issue.
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
**-> If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
Next i
End Sub
Thanks
You are trying to test if an error is = No.
Test for the error and skip the logic in that loop:
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range("AB" & i).Value) Then
If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
End If
Next i
End Sub
I have a VBA script that copies data from rows in the SoapUI - Single Sheet to a STpremcalc Sheet and then copies the final calculation back over to SoapUI - Single Sheet. It works fine but I have 10000 rows of data and it takes around 30 seconds to do one row. When I tested it with 1000 rows it finished within a minute.
What is causing this? Is it because the VBA script is reading the whole worksheet before if copies the values across.
Sub SingleRating()
Dim i As Long
Dim iteration As Variant
Dim seleciton As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("SoapUI - Single")
Set ws2 = Worksheets("STpremcalc")
iteration = 0
iteration = InputBox("Please Select Row Iteration", "", "1000")
seleciton = iteration + 2
For i = 3 To seleciton
ws2.Range("B3").Value = ws1.Range("B" & i).Value
ws2.Range("B4").Value = ws1.Range("C" & i).Value
ws2.Range("B5").Value = ws1.Range("D" & i).Value
ws2.Range("B6").Value = ws1.Range("E" & i).Value
ws2.Range("E3").Value = ws1.Range("F" & i).Value
ws2.Range("E4").Value = ws1.Range("G" & i).Value
ws2.Range("E5").Value = ws1.Range("H" & i).Value
ws2.Range("E6").Value = ws1.Range("I" & i).Value
ws2.Range("G3").Value = ws1.Range("J" & i).Value
ws2.Range("G4").Value = ws1.Range("K" & i).Value
ws2.Range("G5").Value = ws1.Range("L" & i).Value
ws2.Range("J3").Value = ws1.Range("N" & i).Value
ws2.Range("J4").Value = ws1.Range("O" & i).Value
ws2.Range("J6").Value = ws1.Range("P" & i).Value
ws2.Range("B9:E9").Value = ws1.Range("Q" & i, "T" & i).Value
ws2.Range("B10:E10").Value = ws1.Range("U" & i, "X" & i).Value
ws2.Range("B11:E11").Value = ws1.Range("Y" & i, "AB" & i).Value
ws2.Range("B12:E12").Value = ws1.Range("AC" & i, "AF" & i).Value
ws2.Range("B13:E13").Value = ws1.Range("AG" & i, "AJ" & i).Value
ws2.Range("B14:E14").Value = ws1.Range("AK" & i, "AN" & i).Value
ws2.Range("B15:E15").Value = ws1.Range("AO" & i, "AR" & i).Value
ws2.Range("B16:E16").Value = ws1.Range("AS" & i, "AV" & i).Value
'''''''''''''''''''''''''''''''''''''''''''''''''
ws1.Range("AW" & i).Value = ws2.Range("M4").Value
ws1.Range("AX" & i).Value = ws2.Range("M5").Value
ws1.Range("AY" & i).Value = ws2.Range("M6").Value
Application.StatusBar = "Current iteration: " & (i - 2) & "/" & iteration
Next i
End Sub
If that is your whole code I'd suggest inserting this right after initializing your variables:
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
At the very end of your code (above End Sub) reverse it:
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
From my experience especially the ScreenUpdating part gives a massive performance boost when copying / inserting rows. If you still have performance problems after disabling it, we need to look at the implementation itself.
I think this should help you though, as I have copied tens of thousand rows between worksheets and never had a performance issue.
I am looking to see if there is a more efficient way to achieve the result below, so it can be extended if needed.
I'm using this to clean up large spreadsheets that have the rows C-Z blank. I imagine there should be a way to clean it up so that it doesn't have to double in size if I need to clean up a spreadsheet with data from C to AZ.
It's been a while since I used VBA, I found the code below online. (counting ROW B as the spreadsheet in question had an empty ROW A)
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
If Range("C" & r).Value = "" And Range("D" & r).Value = "" And Range("E" & r).Value = "" And Range("F" & r).Value = "" And Range("G" & r).Value = "" And Range("H" & r).Value = "" And Range("I" & r).Value = "" And Range("J" & r).Value = "" And Range("K" & r).Value = "" And Range("L" & r).Value = "" And Range("M" & r).Value = "" And Range("N" & r).Value = "" And Range("O" & r).Value = "" And Range("P" & r).Value = "" And Range("Q" & r).Value = "" And Range("R" & r).Value = "" And Range("S" & r).Value = "" And Range("T" & r).Value = "" And Range("U" & r).Value = "" And Range("V" & r).Value = "" And Range("W" & r).Value = "" And Range("X" & r).Value = "" And Range("Y" & r).Value = "" And Range("Z" & r).Value = "" Then Rows(r).Delete
Next r
End Sub
Thanks!
Just add an inner loop to go through the columns you care about. This will actually run much faster, as VBA doesn't short-circuit the If statement (all of the conditionals are evaluated). But with the loop, you can exit early if you find a value anywhere:
Sub delem()
Dim last As Long
Dim current As Long
Dim col As Long
Dim retain As Boolean
last = Cells(Rows.Count, "B").End(xlUp).Row
For current = last To 1 Step -1
retain = False
For col = 3 To 26
If Cells(current, col).Value <> vbNullString Then
retain = True
Exit For
End If
Next col
If Not retain Then Rows(current).Delete
Next current
End Sub
The Excel worksheet function COUNTA is a clean way to test if a range is empty.
Sub delem()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 1 Step -1
'This function Counts the number of cells that are not empty
If WorksheetFunction.CountA(Range(Cells(r, 3), Cells(r, 26)) = 0 Then
Rows(r).Delete
End If
Next r
End Sub