Loop through a range and delete row if certain condition is met - vba

I am a little bit confused, I was trying to loop through a range of cells, and check if this cell value equals other value stored in the variable, if not, I want to delete the whole row. It is starting with last row in the range, but when I run this macro, it stops after first value, and I want to keep on looping through other values. If I will manually run it again, it will work, but then it will stop on the first cell where cell.value = id1 or id2. Is there a "else continue" in vba? or else next cell? I was trying to play with this and googling it, but no luck.
The IDs values I had in my example was just; 3 & 4. While range of values I was looping through was just 1 to 6
#as suggested below when I changed ws2.Range("A" & LastRow) to a ws2.Range("A1:A" & LastRow) it kind of works, but it doesnt loop through all cells at once, but I need to run this macro twice... to remove all unwanted cells... this is confusing
Sub DeleteRows()
Dim cell As Range
Dim wb As Workbook: Set wb = ThisWorkbook
Set ws = wb.Sheets("ID_value_source")
Set ws2 = wb.Sheets("Sheet2")
Dim LastRow As Long
id1 = ws.Range("A2").Value
id2 = ws.Range("A3").Value
ws2.Activate
LastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For Each cell In ws2.Range("A" & LastRow)
If cell.Value <> id1 And cell.Value <> id2 Then
cell.EntireRow.Delete
End If
Next cell
End Sub
Thanks
eM

update - based on the feedback & help below I managed to solve this, thank you all; this is the code that works for me:
Sub del_Rows()
Dim wb As Workbook: Set wb = ThisWorkbook
Set ws = wb.Sheets("ID_value_source")
Set ws2 = wb.Sheets("Sheet1")
Dim LastRow As Long
id1 = ws.Range("A2").Value
id2 = ws.Range("A3").Value
LastRow = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
For i = LastRow To 2 Step -1
If ws2.Cells(i, 1).Value <> id1 And ws2.Cells(i, 1).Value <> id2 Then ws2.Rows(i & ":" & i).EntireRow.Delete
Next i
End Sub

Related

Trying to replace 1 value with a conditional replaces the whole column

Dim WB As Workbook
Set WB = ThisWorkbook
Dim lrow As Long
lrow = WB.Sheets("Updated Sheet").Range("B" & Rows.Count).End(xlUp).row
Dim myrange As Range
Set myrange = WB.Sheets("Updated Sheet").Range("R2:R" & lrow)
Dim row As Long
Dim col As Long
row = WB.Sheets("Updated Sheet").Range("AJ2").row
col = WB.Sheets("Updated Sheet").Range("AJ2").Column
For Each cl In myrange 'myrange is basically column "R"
If wb.Sheets("Updated Sheet").Cells(row, col) = "Paid" Then
cl.value = "Paid"
Else
End If
row = row + 1
Next cl
This is the code I currently have for an if statement where I want to replace the value in column R with the string "Paid" if the value in (row, col) is "Paid" as well.
However, the function currently replaces all values in column R even if there is only one "Paid" match, even though running through with f8/adding a msgbox line shows that the value in cell(row, col) is not "paid" for every line.
How should I go about fixing this?
Try Autofilter instead of looping through cells.
Please give this a try...
Sub David()
Dim WB As Workbook
Dim WS As Worksheet
Dim lrow As Long
Set WB = ThisWorkbook
Set WS = WB.Sheets("Updated Sheet")
WS.AutoFilterMode = False
lrow = WB.Sheets("Updated Sheet").Range("B" & Rows.Count).End(xlUp).row
With WS.Range("AJ1:AJ" & lrow)
.AutoFilter field:=1, Criteria1:="Paid"
If WS.Range("R1:R" & lrow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
WS.Range("R2:R" & lrow).SpecialCells(xlCellTypeVisible).Value = "Paid"
End If
.AutoFilter
End With
End Sub
Add .value to your cell reference. Currrently you are comparing a string with a cell object. That could lead to strange results.
If wb.Sheets("Updated Sheet").Cells(row, col).value = "Paid" Then

Do not run paste macro if all cells in a column are empty

I have a macro that looks for records in Column B and if there is a value in a cell within that column then the macro will add a value to Column A in the same row. My problem occurs when Column B has NO values in it whatsoever. The macro just continues running endlessly in those instances. What I am looking for is a way to say:
If Column B contains NO value then skip to the next macro.
I know this involves an IF statement of some kind I just can not figure out how to add that logic into my existing code.
My code:
Sub Update_Column_Based_On_Column_Value_1()
On Error Resume Next
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=If(LEN(RC2),""NEW VALUE GOES HERE"", TEXT(,))"
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End Sub
My search for the answer yielded this string of code from another StackOverflow question:
If WorksheetFunction.CountBlank(emailRng) = emailRng.Cells.Count Then Exit Sub 'No data
When I added that to my code it simply ended the sub if there were ANY blank cells in a column.
Thanks in advance for the assistance! I do apologize if my question is overly noobish.
Try this:
Sub Update_Column_Based_On_Column_Value_1()
On Error Resume Next
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
' This will count all non-blanks in Column B, I put equal to 1
' because I am assuming B1 is a header with a title so it will at minimum be 1
If WorksheetFunction.CountA(ws.Range("B:B")) = 1 Then
' if count is equal to 1 then this part will run
' so enter name of the sub() or write new code in here
Else
' if not less than or equal, meaning greater than 1
' then the following code below will run
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=If(LEN(RC2),""NEW VALUE GOES HERE"", TEXT(,))"
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End If
This code will do what you want
Sub test()
Dim i As Long
Dim lRow As Long
lRow = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lRow
If Cells(i, "B").Value <> vbNullString Then
Cells(i, "A").Value = Cells(i, "B").Value
End If
Next i
End Sub

reference issue using vba

I have 3 columns, with headers A B & C as shown at the picture, and I want to check if the value in column A is equal to 10% of column B, if yes, I want to set it to be the value for column C, if not, I want to get 10% of values in column B. I am in sheet1 and I want to set a VBA button in sheet2 to run the codes.
Here is the code:
Sub Macro1()
Dim ws As Worksheet, lastrow As Long
Set ws = Worksheets("sheet1")
ws.Activate
ActiveCell.Formula = "=IF(A2=B2*0.1, A2, B2*0.1)"
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("C2").AutoFill Destination:=Range("C2:C" & lastrow), Type:=xlFillDefault
End Sub
My issues is if I point my mouse at C2 in sheet1 and I just run the vba codes, it will work. If I am at sheet2 and pressing the button, it won't work, it just doesn't show any data. Is there a way to set values to column C based on my criteria?
To make the code working on sheet1 independently of active sheet is, you need to apply .Range method exactly to Worksheets("sheet1") object. Try the below code:
Sub Macro1()
Dim lastrow As Long
With Worksheets("sheet1")
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
If lastrow = 1 Then
MsgBox "No data"
Exit Sub
End If
.Range("C2:C" & lastrow).Formula = "=IF(A2=B2*0.1, A2, B2*0.1)"
End With
End Sub
Why not to be more straightforward: always set the value to column C equal to 10% of column B? The result will be the same.
Sub Macro1()
Dim lastrow As Long
With Worksheets("sheet1")
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
If lastrow = 1 Then
MsgBox "No data"
Exit Sub
End If
.Range("C2:C" & lastrow).Formula = "=B2*0.1"
End With
End Sub

Apply formula to a range of cells

I have some code which I know works, I am applying a SUMIF formula to a range of cells. It works but it add a load of extra row at the bottom that shouldn't be there. I tried adding in a do until loop but it gets stuck in an infinite loop and crashes.
This is my first lot of code which works but adds the extra row in only on the columns which have been copied over.
Dim z As Workbook 'Budget Workbook
Dim y As Workbook 'Formatted - current workbook
Dim lastRow As Integer
Dim budgLastRow As Integer
Dim rng As Range
Set y = Workbooks("DLT.xlsm")
Set z = Workbooks.Open("C:\Reports\Budget.xlsx")
'Apply function to columns to pull costing data
With y.Worksheets("DLT")
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
For Each rng In .Range("AI22:AI" & lastRow)
rng.Formula = "=SUMIF('[Budget.xlsx]DynamicReport'!$C:$C,$E" & rng.Row & ",'[Budget.xlsx]DynamicReport'!H:H)"
rng.Value = rng.Value
Next rng
For Each rng In .Range("AJ22:AJ" & lastRow)
rng.Formula = "=SUMIF('[Budget.xlsx]DynamicReport'!$C:$C,$E" & rng.Row & ",'[Budget.xlsx]DynamicReport'!I:I)"
rng.Value = rng.Value
Next rng
For Each rng In .Range("AN22:AN" & lastRow)
rng.Formula = "=SUMIF('[Budget.xlsx]DynamicReport'!$C:$C,$E" & rng.Row & ",'[Budget.xlsx]DynamicReport'!E:E)"
rng.Value = rng.Value
Next rng
For Each rng In .Range("AO22:AO" & lastRow)
rng.Formula = "=SUMIF('[Budget.xlsx]DynamicReport'!$C:$C,$E" & rng.Row & ",'[Budget.xlsx]DynamicReport'!G:G)"
rng.Value = rng.Value
Next rng
End With
I think the other additional rows have been copied because the budget workbook contains more data then the formatted work book. I have know thought to possibly delete the other unnecessary row which have been copied cross.
So I have added this small piece of code in
With y.Worksheets("Formatted")
lastRow = Cells(Rows.Count, 5).End(xlUp).Row - 1
budgLastRow = Cells(Rows.Count, 35).End(xlUp).Row
Rows("AI" & lastRow & ":AO" & budgLastRow).EntireRow.Delete
End With
I get an application-defined error Object defined error on the line
Rows("AI" & lastRow & ":AO" & budgLastRow).EntireRow.Delete
This is probably not the most efficient way to do this, but its the only way I could think of. I am fairly new to VBA only been coding a couple of months so mostly just try out different ways and see what works. Can anyone help me please.
You didn't properly qualify the ranges for the lastRow variable:
lastRow = .Cells(.Rows.Count, 5).End(xlUp).Row
Note the dots before Cells and Rows.
A couple of additional points:
Always use Long rather than Integer for row variables as there are more rows in a sheet than an Integer can hold.
You don't need to loop to put the same formula in a column of cells.
Dim z As Workbook 'Budget Workbook
Dim y As Workbook 'Formatted - current workbook
Dim lastRow As Long
Dim budgLastRow As Long
Set y = Workbooks("DLT.xlsm")
Set z = Workbooks.Open("C:\Reports\Budget.xlsx")
'Apply function to columns to pull costing data
With y.Worksheets("DLT")
lastRow = .Cells(.Rows.Count, 5).End(xlUp).Row
With .Range("AI22:AJ" & lastRow)
.Formula = "=SUMIF('[Budget.xlsx]DynamicReport'!$C:$C,$E22,'[Budget.xlsx]DynamicReport'!H:H)"
.Value2 = .Value2
End With
With .Range("AN22:AN" & lastRow)
.Formula = "=SUMIF('[Budget.xlsx]DynamicReport'!$C:$C,$E22,'[Budget.xlsx]DynamicReport'!E:E)"
.Value2 = .Value2
End With
With .Range("AO22:AO" & lastRow)
.Formula = "=SUMIF('[Budget.xlsx]DynamicReport'!$C:$C,$E22,'[Budget.xlsx]DynamicReport'!G:G)"
.Value2 = .Value2
End With
End With

How do I conditionally append a row of Excel data from one sheet to another?

I don't use Excel very often, but I'm hoping there is a fairly straightforward way to get through this. I looked through a number of other solutions involving pasting data from one sheet to another, but I couldn't find anything that would allow me to (1) match a cell from one sheet to another and then (2) conditionally append or concatenate data instead of simply pasting it over.
I have an Excel document with two sheets of data. Both sheets contain a numerical ID column.
I basically need to match the ID's from Sheet2 to the Sheet1 and then append the row data from Sheet2 to the matching rows from Sheet1. I would imagine it will look something like this:
If Sheet2 ColumnA Row1 == Sheet1 ColumnA RowX
Copy Sheet2 Row1 Columns
Paste (Append) to Sheet1 RowX (without overwriting the existing columns).
Sorry if there is a better way to form this question. I've managed to think myself in circles and now I feel like I have a confused Nigel Tufnel look on my face.
[Update: Updated to clarify cells to be copied.]
I think this is what you are trying to do?
The code is untested. I believe it should work. If you get any errors, let me know and we will take it form there...
Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1LR As Long, ws2LR As Long
Dim i As Long, j As Long, LastCol As Long
Dim ws1Rng As Range, aCell As Range
Dim SearchString
Set ws1 = Sheets("Sheet1")
'~~> Assuming that ID is in Col A
'~~> Get last row in Col A in Sheet1
ws1LR = ws1.Range("A" & Rows.Count).End(xlUp).Row
'~~> Set the Search Range
Set ws1Rng = ws1.Range("A1:A" & ws1LR)
Set ws2 = Sheets("Sheet2")
'~~> Get last row in Col A in Sheet2
ws2LR = ws2.Range("A" & Rows.Count).End(xlUp).Row
'~~> Loop through the range in Sheet 2 to match it with the range in Sheet1
For i = 1 To ws2LR
SearchString = ws2.Range("A" & i).Value
'~~> Search for the ID
Set aCell = ws1Rng.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If found
If Not aCell Is Nothing Then
LastCol = ws2.Cells(i, ws2.Columns.Count).End(xlToLeft).Column
'~~> Append values
For j = 2 To LastCol
ws1.Cells(aCell.Row, j).Value = ws1.Cells(aCell.Row, j).Value & " " & ws2.Cells(i, j).Value
Next j
End If
Next i
End Sub
HTH
Sid
This should work:
For Each cell2 In Sheet2.UsedRange.Columns(1).Cells
For Each cell1 In Sheet1.UsedRange.Columns(1).Cells
If cell2.Value = cell1.Value Then
Sheet1.Range("B" & cell1.Row & ":Z" & cell1.Row).Value = Sheet2.Range("B" & cell2.Row & ":Z" & cell2.Row).Value
End If
Next cell1
Next cell2