I'm trying to update a sheet with an import of a .CSV file..
I can read and update all the information. After the update I want to remove some data. All the rows with D empty must be deleted (whole row).
For that, I have a foreach that checks D3:D486 (is last row).
After running the macro, there are some rows deleted, but not all the rows.
Dim rCell As Range
Dim rRng As Range
Debug.Print CStr(LastRow)
Set rRng = Worksheets("sheet1").Range("D3:D" + CStr(LastRow))
For Each rCell In rRng.Cells
If Not IsEmpty(rCell) Then
Debug.Print rCell.Row
Else
Debug.Print "Empty"
Worksheets("sheet1").Rows(rCell.Row).Delete
End If
Next rCell
I guess there is a problem with the for-each.. By example, If he delete row 100, the next time he goes to row 101.. But thats previous row 102..
I can save the cells maybe in an array, but then it would be the same.
Except if I go the other way (from bottom to top). How can I solve this?
i think you've answered your own question: from bottom to top...
and you can try range.EntireRow.Delete method too, something like below
Dim rCell As Range
Dim lastRow, i
lastRow = 1000
For i = lastRow To 1 Step -1
' if condition met
Worksheets("Sheet1").Range("D:" + i).EntireRow.Delete
Next
I would do it like this:
Dim i As Integer
Dim rRng As Range
Debug.Print CStr(LastRow)
Set rRng = Worksheets("sheet1").Range("D3:D" + CStr(LastRow))
For i = 1 To rRng.Cells.Count
If Not IsEmpty(Worksheets("Sheet1").Range("D:" + i).Value) Then
Debug.Print rCell.Row
Else
Debug.Print "Empty"
Worksheets("Sheet1").Range("D:" + i).EntireRow.Delete
i = i - 1
End If
Next
Rex answer is correct, if you want to get cute you can also do it this way:
Sub DeleteRowsWithCriteria()
Dim rng As Range, rngCell As Range, rngDelete As Range
Set rng = Worksheets("sheet1").UsedRange.Columns("D:D").Cells 'Watch out here, if columns A-C are not all used, this doesn't work
For Each rngCell In rng
If rngCell.Value = "" Then
If rngDelete Is Nothing Then
Set rngDelete = rngCell
Else
Set rngDelete = Union(rngDelete, rngCell)
End If
End If
Next rngCell
rngDelete.EntireRow.Delete xlShiftUp
End Sub
Related
I have some data that has both words and values in cells and I am trying to delete the rows that don’t have values in the cells. My code works now if all of the numbers are negative but if there are positive numbers then my code won’t work. How do I fix this?
Sub tval
Dim s As Long
Dim LastRow As Long
S=2
LastRow= cells.find(“*”,[A1],,, xlByRows,xlPreviousRow).row
Do until s>LastRow
DoEvents
If InStr(1,Cells(s,4), “-“) > 0 Then
S=s+1
Else
Cells(s,4).EntireRow.Delete
LastRow=LastRow -1
End if
Loop
End sub
When deleting rows, you should always start from the end.
Sub tval
Dim s As Long
Dim LastRow As Long
LastRow= Cells(Rows.Count, 1).End(xlUp).Row
For s= LastRow to 2 Step -1
If Not IsNumeric(Cells(s,4)) then
Cells(s,4).EntireRow.Delete
End if
Next s
End sub
This should work for you:
Sub tgr()
Dim ws As Worksheet
Dim rTextConstants As Range
Dim rTextFormulas As Range
Dim rCombined As Range
Set ws = ActiveWorkbook.ActiveSheet
'Exclude row 1 so that only text values found in rows 2+ are found
With ws.Range("A2", ws.Cells(ws.Rows.Count, ws.Columns.Count))
On Error Resume Next 'prevent error if no cells found
Set rTextConstants = .SpecialCells(xlCellTypeConstants, xlTextValues)
Set rTextFormulas = .SpecialCells(xlCellTypeFormulas, xlTextValues)
On Error GoTo 0 'remove on error resume next condition
End With
If Not rTextConstants Is Nothing Then Set rCombined = rTextConstants
If Not rTextFormulas Is Nothing Then
If rCombined Is Nothing Then Set rCombined = rTextFormulas Else Set rCombined = Union(rCombined, rTextFormulas)
End If
If Not rCombined Is Nothing Then
rCombined.EntireRow.Delete
Else
MsgBox "No cells containing text found in sheet '" & ws.Name & "'", , "Error"
End If
End Sub
May I suggest a bit of a different approach:
Before:
Code:
Dim RNG1 As Range, RNG2 As Range
Option Explicit
Sub TestCase()
With ActiveWorkbook.Sheets(1)
Set RNG1 = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
If RNG1.SpecialCells(xlCellTypeConstants, 1).Count <> RNG1.Cells.Count Then
Set RNG2 = Application.Intersect(RNG1, RNG1.SpecialCells(xlCellTypeConstants, 2))
RNG2.EntireRow.Delete
End If
End With
End Sub
After:
You'll need to change this around to suit your range obviously. It should be a good starting point nonetheless.
You can also use AutoFilter to filter the numbers, and delete the visible cells to accomplish this task. The code accounts for a header row.
With ThisWorkbook.Sheets("Sheet1")
With .Range("A1").CurrentRegion
.AutoFilter
.AutoFilter Field:=4, Criteria1:="<>*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End With
I am learning VBA as I go along and have managed to compile a lot of code from a range of sources but am finding it hard to solve my current problem. I have read a lot of solutions regarding working with ranges but I have been unable to adapt any of the ones that I have seen to resolve my issue.
I would like a macro which, when a Command Button is pressed, will identify the last used row in a range of cells (which will increase in row count over time) then check each row for any empty cells within the range and filling these with the letter 'N' if there is data in the same row in Column A.
I currently have the following code:
Private Sub CBtnFillAll_Click()
'
' EmptyCharacteristic Macro
' Fills empty cells in the characteristics columns with 'N'
'
Dim Lastrow As Integer
Dim rCell As Range
Dim rRng As Range
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rRng = ActiveSheet.Range("$H$3:$S" & Lastrow)
For Each rCell In rRng.Rows
If rCell.Value = "" And ActiveSheet.Cells(rRng.Row, 1).Value <> "" Then
rCell.Value = "N"
End If
Next rCell
End Sub
I am checking Column A as there is additional data starting in Column B in rows which I do not want to include in the range. The range to check will always be between Columns H and S.
I am currently getting a 'Type Mismatch' error in the following line:
If rCell.Value = "" And ActiveSheet.Cells(rRng.Row, 1).Value <> "" Then
Please can someone help me with the syntax in this final part?
Many thanks in advance.
Your approach is completely correct, but there is one thing that creates the problem:
Change your For Each line to this: For Each rCell in rRng.
There are a few things I would have done differently, so here is my complete code:
Sub test()
Application.ScreenUpdating = False
Dim Lastrow As Long
Dim rCell As Range
Dim aCell As Range
Dim rRng As Range
Dim Currentrow As Long
Lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set rRng = ActiveSheet.Range("H3:S" & Lastrow)
For Each rCell In rRng
Currentrow = rCell.Row
Set aCell = ActiveSheet.Range("A" & Currentrow)
If Not IsEmpty(aCell.Value) And IsEmpty(rCell.Value) Then
rCell.Value = "N"
End If
Next
Application.ScreenUpdating = True
End Sub
I think that this may do what you are looking for
Sub CBtnFillAll_Click()
' EmptyCharacteristic Macro
' Fills empty cells in the characteristics columns with 'N'
'
Dim rCell As Range, _
rRng As Range
For Each rRng In ActiveSheet.UsedRange.Columns("A:A").Cells
If IsEmpty(rRng) Then GoTo NextRow
For Each rCell In rRng.Offset(0, 7).Resize(1, 12)
If IsEmpty(rCell) Then rCell.Value = "N"
Next rCell
NextRow:
Next rRng
End Sub
If you are looking to omit the first two lines of your sheet, then you can change
For Each rRng In ActiveSheet.UsedRange.Columns("A:A").Cells
to
For Each rRng In ActiveSheet.[A3].Resize(ActiveSheet.UsedRange.Rows.Count-2)
I am trying to write a macro that hides the row if the cell value equals the next visible cell in that column and loops through the whole column. I have read that SpecialCells(xlCellTypeVisible) only works up to 8192 cells and my spreadsheet has 15,000 rows.
I have tried something like this but want to restrict it to only visible cells
Sub Test()
For i = 7 To 15258
If Range("P" & i).Value = Range("P" & i + 1).Value Then
Rows(i).Hidden = True
End If
Next i
End Sub
I have tried to search for a solution but haven't been able to find one yet.
Thanks!
I'd be surprised if this couldn't be optimized just a little bit, but it will work for what you are needing.
You can follow the comments within the code itself to kind of get a sense of what it's doing, but in a nutshell, you are using a For...Next statement to loop through your visible cells. For each visible cell, you will search for the next visible cell and then check to see if that matches. If it does, you add that cell to a special range that tracks all the rows to hide at the end of the code, then hide it.
Sub Test()
Dim ws As Worksheet, lookupRng As Range, rng As Range, lstRow As Long
Set ws = ThisWorkbook.Worksheets(1)
lstRow = 15258
Set lookupRng = ws.Range("P7:P" & lstRow)
Dim rngToHide As Range, i As Long
For Each rng In lookupRng.SpecialCells(xlCellTypeVisible)
Application.StatusBar = "Checking row " & rng.Row & " for matches."
For i = rng.Row + 1 To lstRow 'Loop through rows after rng
If Not ws.Rows(i).Hidden Then 'Check if row is hidden
If rng.Value = ws.Cells(i, "P") Then 'check if the non-hidden row matches
If rngToHide Is Nothing Then 'Add to special range to hide cells
Set rngToHide = ws.Cells(i, "P")
Else
Set rngToHide = Union(rngToHide, ws.Cells(i, "P"))
End If
End If
Exit For 'Exit the second For statement
End If
Next i
Next rng
Application.StatusBar = "Hiding duplicate rows"
If Not rngToHide Is Nothing Then rngToHide.EntireRow.Hidden = True
Application.StatusBar = False
End Sub
I'm trying to use VBA in a macro to search for a text string and delete the contents of the column. I previously found this on the website and would like to change it to search columns and delete the text "QA1" while retaining the columns. I hope this makes sense.
LastRow = Cells(Columns.Count, "D").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("D" & i).Value = "D" Then
Range("D" & i).EntireColumn.Delete
End If
Next i
You want to clear the contents of the whole column if one cell contains QA1?
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Columns(4)
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
.ClearContents
End If
End With
End Sub
If you want to just clear each instance of QA1 in column D:
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Columns(4)
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
Do
rCell.ClearContents
Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing
End If
End With
End Sub
Can it be written to look through the entire worksheet and delete QA1
where ever it is found?
All instances of QA1 on sheet:
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Cells
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
Do
rCell.ClearContents
Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing
End If
End With
End Sub
Edit: Add LookAt:=xlWhole to the Find arguments so it doesn't delete cells containing QA1 and other text (e.g. QA11 or Some text QA1)
This code goes through columns in a specified row and removes the "QA1" if found
Dim LastColumn As Integer
Dim RowNumber As Integer
Dim i As Integer
LastColumn = UsedRange.SpecialCells(xlCellTypeLastCell).Column
RowNumber = 1 'Adjust to your needs
For i = 1 To LastColumn Step 1
Cells(RowNumber, i).Value = Replace(Cells(RowNumber, i).Value, "QA1", "")
Next i
Loops through the used range of the active worksheet, and removes the selected text.
Sub RemoveText()
Dim c As Range
Dim removeStr As String
removeStr = InputBox("Please enter the text to remove")
For Each c In ActiveSheet.UsedRange
If c.Value = removeStr Then c.Delete
Next c
End Sub
Have a range of cell with column headings as weeks In the range of cells I want to look for a number, say
1 if it finds a 1 then look at a column in said row for a variable, 2 or 4 whatever Now I want to put a triangle (can be copy and paste a cell) in the cell that has the "1" in it then skip over the number of week variable and add another triangle and keep doing this until the end of the range. Then skip down to the next row and do the same, until the end of the range.
Then change to the next page and do the same thing... through the whole workbook.
I think I have it done, don't know if it's the best way.
I get a error 91 at the end of the second loop, the first time the second loop ends it goes through the error code.
The second time the second loop ends it errors.
I don't understand it runs through once, but not twice.
Sub Add_Triangles2()
Dim Rng As Range
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Dim ws As Worksheet
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Worksheets(1).Activate
Worksheets(1).Range("A1").Select ' Has item to be pasted (a triangle)
Selection.Copy
For Each ws In Worksheets
Worksheets(ws.Name).Activate
With Range("C4:G25")
Set Rng = .Find(1, LookIn:=xlValues)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Activate
ActiveSheet.Paste
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
End With
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
I was not able to get an Error 91 using the data set I built from your explanation, maybe a screenshot of the layout could help recreate the issue.
However, I would do something like this, it will look at the value of each cell in the range C4:G25, and if it equals 1, it will paste the symbol stored in Cell A1.
Sub Add_Triangles2()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
End If
Next Rng
Next ws
End Sub
I got it....
Sub Add_TriWorking()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
Rng.Activate
ActiveCell.Copy
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
End If
Next Rng
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub