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)
Related
I am processing a data set that has about 50 columns, and the same columns are always off by a factor of ten. So, I just want to hardcode the specific columns (starting with F here) and divide every cell in the column by 10. Right now I am getting a "Type Mismatch" error. The code is below:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
cell.Value = cell.Value / 10
Next cell
End Sub
why loop when you can simply paste special and divide.
errors within the cells are ignored.
in vba, here is the code
Range("G10").Copy
Range("B2:E8").PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide
Application.CutCopyMode = False
test if cell is an error and then test if it is a number prior to dividing:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
If Not IsError(Cell) Then
If IsNumeric(cell) and cell <> "" Then
cell.Value = cDbl(cell.Value) / 10
End If
End If
Next cell
End Sub
I am trying to create a code that will search for a given column header and copy the contents of the column after first replacing all the blanks with a zero.
I have tried using the following code, but the second parameter for the range function at the bottom does not work when I try to use "lastrow".
lastrow is defined by the numeric last row value, but I cant seem to figure out how to combine that with the alphabetical reference that is given in dbt.address
`Sub replacezeros()
Dim dbt As Range
Dim lastrow As Range
'This is to define last row of array
Set lastrow = Range("A" & Rows.Count).End(xlUp)
Debug.Print lastrow.Row
'This is for Debit
Set dbt = Range("A1:J1").Find("Debit")
Debug.Print dbt.Address
Debug.Print dbt.Cells
'Range(dbt.Address,).SpecialCells(xlCellTypeBlanks) = 0
End Sub`
Hoping to get this to replace all zeros only in that one column that is searched to select "Debit"
Not sure if I've understood your problem - try this:
Sub replacezeros()
Dim dbt As Range
Dim lastrow As Range
'This is to define last row of array
Set lastrow = Range("A" & Rows.Count).End(xlUp)
Debug.Print lastrow.Row
'This is for Debit
Set dbt = Range("A1:J1").Find("Debit")
If Not dbt Is Nothing Then 'avoid error if Debit not found
On Error Resume Next 'avoid error if no blanks
Range(dbt.Offset(1), Cells(lastrow.Row, dbt.Column)).SpecialCells(xlCellTypeBlanks).Value = 0
On Error GoTo 0
End If
End Sub
Something like this should work... (untested though)
Sub replacezeros()
Dim dbt As Range, rData As Range, Cell As Range
Dim lastrow As Long: lastrow = Range("A" & Rows.Count).End(xlUp).Row
'This is for Debit
Set dbt = Range("A1:J1").Find("Debit")
If Not dbt Is Nothing Then
Set rData = Range(Cells(1,dbt.Column),Cells(lastrow, dbt.Column))
For Each Cell In rData.SpecialCells(xlCellTypeBlanks)
Cell.Value = 0
Next Cell
End If
End Sub
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
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
I get this error when I am trying to open a UserForm. What I want is to add to a combobox all the different objects (not repeated) that are present in a column.
I have been looking some solutions around there and all I can say until now is Yes, I have a combobox called "offer1"
When it gives me the error, it highlight the .FindString() method inside the loop
Private Sub UserForm_Initialize()
Dim rCell As Range
Dim i As String
Dim ws As Worksheet
Dim text As String
text = rCell.text
ws = Offers
offer1.Clear
With offer1
For Each rCell In Sheets("Offers").Range("A2", Sheets("Offers").Cells(Rows.Count, "A").End(xlUp))
If TEST.offer1.FindString(text) = -1 Then
.AddItem CStr(text)
End If
Next rCell
End With
End Sub
(If you see some silly mistakes with the names of variables as "Ofertas" or something like that is probably that I translated some variable names to english, and I jumped over a few)
Thanks a lot
Replace your code with this:
Option Explicit
Private Sub UserForm_Initialize()
Dim rCell As Range
Dim ws As Worksheet
Dim LastRow As Long
Dim strFirstCell As String
Set ws = Sheets("Offers")
With Me.offer1
.Clear
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
strFirstCell = ws.Cells(2, "A").Address
For Each rCell In ws.Range(strFirstCell, ws.Cells(Rows.Count, "A").End(xlUp))
If Evaluate("=SUMPRODUCT((" & strFirstCell & ":" & rCell.Address(0, 0) & "=" & rCell.Address & ")+0)") = 1 And rCell.Value <> "" Then
.AddItem rCell.Value
End If
Next rCell
End With
End Sub
This will fill your combobox with all the unique items in column A, starting at row 2, while also skipping any blanks.