I need to delete 2 or more (variable depending on work) cells in the same row starting from row 2 if the 2 cells are = ""
I used this code and it's already working fine except 1 problem
Sub Macro3()
Dim s As Integer
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
For s = 2 To 22
If ws.Range("G" & (s)) = "" And ws.Range("H" & (s)) = "" Then
Union(ws.Range("G" & s), ws.Range("H" & s)).Select
Selection.Delete Shift:=xlUp
End If
Next s
End Sub
the problem is if I have for example from G2:H4 (2rows or more achieve the if condition) it's only delete half of them,
if 5 rows delete 3 only...etc
so I think the loop doesn't operate on the current cell (just guessing)
Attach screens is before and after running the code for more clarification
before
after
Sub Macro3()
Dim s As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
For s = 22 To 2 Step -1
If ws.Range("G" & s).Value = "" And ws.Range("H" & s).Value = "" Then
ws.Rows(s).Delete Shift:=xlUp
'or:
'ws.Range("G" & s & ":H" & s).Delete Shift:=xlUp
End if
Next s
End Sub
After running the code:
Related
I'm basically writing a clean up program to make it more straight forward to access data. Anywho, I ran into possibly a nomenclature error. I want to use the "current" cell in a "for" loop to delete that row and the next 3 rows. Code looks something like this:
For Each SingleCell In SingleSheet1.Range("a1:a40")
If SingleCell.Value = "S" Or SingleCell.Value = "B" Then
Range(SingleCell.Range, SingleCell.Range.Offset(4, 0)).EntireRow.Delete Shift:=xlUp
Else
End If
Next
I tried to define the range to delete as specified in the code but it gave me a runtime error
Delete backwards looping trough row number:
Sub EXAMPLE_1()
Dim i As Long
For i = 40 To 1 Step 1
If Range("A" & i).Value = "S" Or Range("A" & i).Value = "B" Then Range("A" & i & ":A" & i + 3).EntireRow.Delete Shift:=xlUp
Next i
End Sub
Sub EXAMPLE_2()
Dim i As Long
Dim LR As Long 'in case last row is not always number 40, adapt it dinamically
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step 1
If Range("A" & i).Value = "S" Or Range("A" & i).Value = "B" Then Range("A" & i & ":A" & i + 3).EntireRow.Delete Shift:=xlUp
Next i
End Sub
Your code looses the reference for the deleted rows and you should iterate backwards, if you like iteration between cells (which is slow), but a better/faster solution will be to build a Union range and delete all rows at the code end, at once:
Sub testDeleteOffset()
Dim sh As Worksheet, Urng As Range, i As Long
Set sh = ActiveSheet
For i = 1 To 40
If sh.Range("A" & i).Value = "S" Or sh.Range("A" & i).Value = "B" Then
addToRange Urng, sh.Range("A" & i, "A" & i + 3)
i = i + 4
End If
Next i
If Not Urng Is Nothing Then Urng.EntireRow.Delete xlUp
End Sub
If the involved range is huge, a better solution will be to place some markers for the necessary rows (after last existing column), sort on that marker column and delete the (consecutive marked) rows. Another column with the initial order would be necessary to re-sort according to it at the end... The idea is that building a Union range having more than 1000 areas may become slow.
We have an Excel macro that cleans up a spreadsheet containing thousands of rows. It starts from the bottom of the sheet and deletes rows that meet certain criteria.
I am told that this macro used to take a few minutes to run, and now it takes an hour. It used to zip up the spreadsheet, and now it takes about a second per row, which obviously adds up.
We recently upgraded from Excel 2007 to Excel 2016, so I am not sure if that is the cause. I have tried the macro on multiple computers and it is slow on all of them, so I don't think it's a faulty install issue. It may just be that the code is written inefficiently, or the spreadsheets have gotten larger. Not sure what else would cause this change.
Here is the code:
Sub DeleteExtraRows()
Dim RowCount As Integer
Dim i As Integer
RowCount = ActiveSheet.Cells(Rows.count, "B").End(xlUp).row
'Delete the Rows
For i = RowCount To 2 Step -1
Range("A" & i).Select
If (Range("A" & i).Style = "Neutral" And Range("AC" & i) = False) Or (Range("U" & i) = 1 And Range("V" & i) = 0 And Range("AC" & i) = False) Then
Rows(i).Delete
End If
Application.StatusBar = RowCount - i & " of " & RowCount & " Records Processed"
Next i
'Delete all the checkboxes
ActiveSheet.CheckBoxes.Delete
Range("A:A").Delete
Application.StatusBar = False
'Move to the top
Range("A2").Select
End Sub
Delete Thousands of Rows
I recently encountered a code that used the status bar in a similar way and slowed down the code dozens of times. Don't do that if it's not necessary.
Not tested.
Option Explicit
Sub DeleteExtraRows()
With ActiveSheet
'Delete the rows
Dim RowCount As Long: RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
Dim drg As Range
Dim i As Long
For i = 2 To RowCount
If (.Range("A" & i).Style = "Neutral" And .Range("AC" & i) = False) _
Or (.Range("U" & i) = 1 And .Range("V" & i) = 0 _
And .Range("AC" & i) = False) Then
If drg Is Nothing Then
Set drg = .Rows(i)
Else
Set drg = Union(drg, .Rows(i))
End If
End If
Next i
If Not drg Is Nothing Then
drg.Delete
End If
'Delete all the checkboxes
.CheckBoxes.Delete
.Range("A:A").Delete
'Move to the top
.Range("A2").Select
End With
End Sub
Okay, so I feel like I am getting closer but I am running in to an object error. I am trying to replace old values in an excel sheet with the new charge values. Here is an example of what I am trying to do.
This is an example of the type of table I might start out with.
This is what I want it to look like after I run the VBA
Here is what I have so far.
Sub Testing()
Dim x As Integer
Dim UpdateRng As Range
Dim SelectRng As Range
v = 2
Application.ScreenUpdating = False
' Get count
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
' Cycle through loop
For x = 1 To NumRows
Set SelectRng = Range("C" & v & ":" & "F" & v) 'Set range
If "A" & v.Vaule = " " Or v.Value = "" Then GoTo NextV
For Each UpdateRng In SelectRng
If UpdateRng.Value > 0 Then
UpdateRng.Value = Range("A" & v).Value
End If
Next
NextV:
v = v + 1
Next
Application.ScreenUpdating = True
End Sub
Add Option Explicit to the top of the module and declare all variables.
Avoid using GoTo as that generally creates spaghetti code.
Use End(xlUp) to determine the last row.
Avoid using Select.
Use Long instead of Integer.
Sub Testing()
Dim ws As Worksheet
Set ws = ActiveSheet
With ws
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
Dim i As Long
For i = 2 To lastRow
With ws
If Not IsEmpty(.Range("A" & i).Value) Then
.Range("C" & i & ":F" & i).Replace "*", .Range("A" & i).Value
End If
End With
Next
End Sub
Note that this considers all values when replacing, not just values greater than 0. Though I think the >0 check is essentially checking if the cells in columns C:F are not empty.
I got it working with this. However, Bigben's is much cleaner.
Sub Testing()
Dim x As Integer
Dim UpdateRng As Range
Dim SelectRng As Range
v = 2
Application.ScreenUpdating = False
' Get count
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
' Cycle through loop
For x = 1 To NumRows
Set SelectRng = Range("C" & v & ":" & "F" & v) 'Set range
If Range("A" & v).Value = " " Or Range("A" & v).Value = "" Then GoTo NextV
For Each UpdateRng In SelectRng
If UpdateRng.Value > 0 Then
UpdateRng.Value = Range("A" & v).Value
End If
Next
NextV:
v = v + 1
Next
Application.ScreenUpdating = True
End Sub
I am trying to create an save button that will copy/paste the previous answer to a new row. But not just one, I want it to save up as many as you can, listing them below each other.
It is just for a school project, to make a master cheat sheet.
Private Sub Save1_Click()
Dim rA5 As Range
Set rA5 = ThisWorkbook.Sheets(1).Range("A5:E5")
Dim rA7 As Range
Set rA7 = ThisWorkbook.Sheets(1).Range("A7:E7")
If (Range("rA7").Value <> "") Then
If (Range("rA7").Offset(1).Value <> "") Then
Set rA7 = rA7.End(xlDown)
End If
Set rA7 = rA7.Offset(1)
End If
rA7.Value = rA5.Value
End Sub
It only pastes the A5:E5 to A7:E7.
It doesn't go down after that to A8:E8, A9:E9 (and so on)
Preferred outcome image
As per your comment on your own question, it looks like you want the newly calculated value on the top line, and the rest pushed down a line. If that is right, then #Error1004 answer won't work as it sticks your values on the end. The following is his code with an added reverse loop which will stick your new value on the top line and push it down:
Sub test()
Dim LastRow As Long
Dim i As Integer
With ThisWorkbook.Worksheets("Sheet1")
'Check if there is a value in A5
If .Range("A5").Value <> "" Then
'Copy range("A5:E5")
.Range("A5:E5").Copy
'If range A7 is empty
If .Range("A7").Value = "" Then
.Range("A7:E7").PasteSpecial Paste:=xlPasteValues
Else
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
i = LastRow
Do While i > 7
.Range("A" & (i + 1) & ":E" & (i + 1)).Value = .Range("A" & i & ":E" & i).Value
i = i - 1
Loop
.Range("A7:E7").Value = .Range("A5:E5").Value
End If
Else
MsgBox "There is no available data to be save."
End If
End With
End Sub
Credit to #Error1004 as I cannibalised his answer for this code.
You could try:
Option Explicit
Sub test()
Dim LastRow As Long
With ThisWorkbook.Worksheets("Sheet1")
'Check if there is a value in A5
If .Range("A5").Value <> "" Then
'Copy range("A5:E5")
.Range("A5:E5").Copy
'If range A7 is empty
If .Range("A7").Value = "" Then
.Range("A7:E7").PasteSpecial Paste:=xlPasteValues
Else
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(LastRow + 1, "A"), .Cells(LastRow + 1, "E")).PasteSpecial Paste:=xlPasteValues
End If
Else
MsgBox "There is no available data to be save."
End If
End With
End Sub
I have working code that checks for a criteria in each row, and if met, copies that whole row of data over to a different workbook. But! I need to be able to add text to the last column of the copied data (Column S) that essentially labels what criteria was met that made the code copy it over because I will soon be expanding to check for multiple different criteria.
So for every row that meets the criteria and gets copied, I want to add "Criteria1" next to it in column S in the new workbook (it will always be column S that will be the first available column).
I have mangled this code together through inheritance and all of your help, so I don't really even know where to begin.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim CoderBook As Workbook
Dim Referrals As Worksheet
Dim Review As Workbook
Dim Crit As Worksheet
Dim LastRow As Long
Dim NextRow As Long
Dim i As Long
Set CoderBook = Workbooks.Open("Coder Referrals.xlsx")
Set Referrals = CoderBook.Sheets("Sheet1")
Set Review = ThisWorkbook
Set Crit = Review.Sheets("Criteria")
'Search code
LastRow = Crit.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False
'Loop search code
For i = 2 To LastRow
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Or _
Crit.Range("I" & i) <> Crit.Range("J" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Crit.Rows(i).Value
End If
Next i
'End loop code
CoderBook.Close SaveChanges:=True
Application.ScreenUpdating = True
End Sub
Split the or into two statements:
For i = 2 To LastRow
j = Referrals.Cells(Rows.Count, 1).End(xlUp).row + 1
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
Referrals.Range("S" & j).Value = "Criteria1"
End If
If Crit.Range("I" & i) <> Crit.Range("J" & i) Then
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
if Referrals.Range("S" & j).value = vbNullString then
Referrals.Range("S" & j).Value = "Criteria2"
Else
Referrals.Range("S" & j).Value = Referrals.Range("S" & j).Value & ", " & "Criteria2"
End if
Next i