I have an excel document that I use to analyze data sets each data asset I bring in has varying amounts of data. I have tried to write a macro that I assign to a button that can identify delete rows based on the value of a cell. It does not work. What am I doing wrong?
Sub Button2_Click()
[vb]
'This will find how many rows there are
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastRow
End With
Sub sbDelete_Rows_Based_On_Criteria()
Dim lRow As Long
Dim iCntr As Long
lRow = lastRow
For iCntr = lRow To 1 Step -1
'Replaces XX with the variable you want to delete
If Cells(iCntr, 1) = "#N/A" Then
Rows(iCntr).Delete
End If
Next
End Sub
[/vb]
End Sub
Your logic is pretty much there, but your syntax is off. Additionally, you are only checking column A for the value and not column B (per your comments above).
Sub Button2_Click()
Dim lRow As Long
'This will find how many rows there are
With ActiveSheet
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastRow
End With
Dim iCntr As Long
For iCntr = lRow To 1 Step -1
'Replace "#N/A" with the value you want to delete
' Check column A and B for the value.
If Cells(iCntr, 1).Text = "#N/A" Or Cells(iCntr, 2).Text = "#N/A" Then
Rows(iCntr).Delete
End If
Next
End Sub
Or simplified:
Sub Button2_Click()
Dim iCntr As Long
For iCntr = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
'Replace "#N/A" with the value you want to delete
' Check column A and B for the value.
If Cells(iCntr, 1).Text = "#N/A" Or Cells(iCntr, 2).Text = "#N/A" Then
Rows(iCntr).Delete
End If
Next
End Sub
Because you have two subs, you must pass lastRow from one to the other:
Sub Button2_Click()
'This will find how many rows there are
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox lastRow
End With
Call sbDelete_Rows_Based_On_Criteria(lastRow)
End Sub
Sub sbDelete_Rows_Based_On_Criteria(lastRow)
Dim lRow As Long
Dim iCntr As Long
lRow = lastRow
For iCntr = lRow To 1 Step -1
'Replaces XX with the variable you want to delete
If Cells(iCntr, 1).Text = "#N/A" Then
Rows(iCntr).Delete
End If
Next
End Sub
Note:
the sub are unnested
Use .Text
Related
I have a problem that I hope you can help me with.
The below code adds 1 day to todays day in Column B if it finds a repeated value in column A. However I want it to add 2 days if it gets repeated again and so on.
I have tried to illustrate how the codes work in the attached picture. So what I want is cell B10 in the picture to be 20/03/2021. I need to make it automatic so it can run for any number of repeated values.
Sub Add_date2()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
For iCntr = 2 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 2) = Date + 1
Else
Cells(iCntr, 2) = Date
End If
End If
Next
End Sub
Use Application.Countifs:
Sub Add_date2()
Dim ws As Worksheet
Set ws = ActiveSheet 'better to set the actual sheet WorkSheets("Sheet1")
With ws
Dim lastRow As Long
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Dim iCntr As Long
For iCntr = 2 To lastRow
If .Cells(iCntr, 1) <> "" Then
.Cells(iCntr, 2) = Date + Application.CountIfs(.Range(.Cells(2, 1), .Cells(iCntr, 1)), .Cells(iCntr, 1)) - 1
End If
Next
End With
End Sub
Im trying to write a macro that filters the column F from second to last row to check if the values in the column are numeric and if the length is 5. A diffrent length is allowed if the value in the column G on the same row contains "TEST".If the value doesnt meet the criteria the row should be deleted. The macro seems to work but I need to start it multiple times to filter all the values.
here is the macro:
Sub Makro1()
Dim lrow As Long
lrow = Cells(Cells.Rows.Count, "F").End(xlUp).Row
Dim Rng As Range
Set Rng = Range("F2:F" & lrow)
For Each cell In Rng
If Not IsNumeric(cell) Or (Len(cell) <> 5 And
InStr(UCase(cell.Offset(0, 1).Value), "TEST") = 0) Then
cell.EntireRow.Delete
End If
Next
End Sub
Try this code, it uses backward loop, which is recommended when iterating over colletion, that we delete from:
Sub Makro1()
Dim lrow As Long, i As Long, cellValue As String
lrow = Cells(Rows.Count, "F").End(xlUp).Row
For i = lrow To 2 Step -1
cellValue = Cells(i, "F").Value
If Not (IsNumeric(cellValue) And Len(cellValue) = 5) And Cells(i, "G").Value = "TEST" Then
Rows(i).Delete
End If
Next
End Sub
I have column "A1" which list names and some names ending with totals (subtotals). I need a vba code to go through each cell, and if cell contains the word "total", clear that cell and if not move on to the next one. Do this until cell before the cell that contains grand total.
Using the code below, it only looks for totals and not cells that contains more than that "Derek Smith Total". I would also need to add do it until the cell before "Grand Total".
Sub testing101()
Dim lRow As Long
Dim iCntr As Long
lRow = 130
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 1).Value = "*total*" Then
Cells(iCntr, 1).Select
Selection.ClearContents
End If
Next
End Sub
You can use Like -
Sub testing101()
Dim lRow As Long
Dim iCntr As Long
lRow = 130
For iCntr = lRow To 1 Step -1
With Cells(iCntr, 1)
If .Value Like "*total*" Then .ClearContents
End With
Next
End Sub
Sub testing101()
Dim lRow As Long
Dim iCntr As Long
lRow = 130
For iCntr = lRow To 1 Step -1
With Cells(iCntr, 1)
If .Value Like "*total*" Then
if .Value <> "Grand Total" then.ClearContents
End If
End With
Next
End Sub
Hi there I want a code which allows to loop through the columns of Sheet A, and columns which have values>0 would be copied to Sheet B. Did a code with help of some answers from the previous forum question but still having issues as it does not seem to work at the paste destination! Some help would be very much appreciated. The code is as follows:
Sub TestPasteColumnData3()
Dim lastcol As Long
Dim j As Long
With Worksheets("WF - L12 (3)")
lastcol = .Cells(4, Columns.Count).End(xlToLeft).Column
For j = 3 To lastcol
If CBool(Application.CountIfs(.Columns(j), ">0")) Then
.Columns(j).Copy Destination:=Worksheets("Sheet1").Columns(3)
Else
MsgBox ("No Value")
Exit Sub
End If
Next
End With
MsgBox ("Done")
End Sub
You keep pasting to column 3. Try:
.Columns(j).Copy Destination:=Worksheets("Sheet1").Columns(j)
Sub TestPasteColumnData3()
Dim lastcol As Long
Dim j As Long
With Worksheets("WF - L12 (3)")
lastcol = .Cells(4, Columns.Count).End(xlToLeft).Column
For j = 3 To lastcol
'change >0 to <>0 and 3 to j
If CBool(Application.CountIfs(.Columns(j), "<>0")) Then
.Columns(j).Copy Destination:=Worksheets("Sheet1").Columns(j)
Else
MsgBox ("No Value")
Exit Sub
End If
Next
End With
MsgBox ("Done")
End Sub
Pl make 2 changes suggested above your code will work.
#Niva I am yet to find out basic reason of Countifs or CountA not giving desired results. For your immediate requirements you can use an additional program to delete blanks in Sheet1. Please make it Active Sheet and use the following program.
Sub DeleteBlankColumns()
With Worksheets("Sheet1")
Dim lastColumn As Long
lastColumn = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
'MsgBox lastColumn
Dim lastRow As Long
Dim rng As Range
Set rng = ActiveSheet.Cells
lastRow = rng.Find(What:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
'MsgBox lastRow
'Step1: Declare your variables.
Dim MyRange As Range
Dim iCounter As Long
'Step 2: Define the target Range.
Set MyRange = ActiveSheet.Range(Cells(1, 1), Cells(lastRow, lastColumn))
'Step 3: Start reverse looping through the range.
For iCounter = MyRange.Columns.Count To 1 Step -1
'Debug.Print iCounter
'Step 4: If entire column is empty then delete it.
Debug.Print Application.CountA(Columns(iCounter).EntireColumn) = 0
If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then
Columns(iCounter).Delete
End If
'Step 5: Increment the counter down
Next iCounter
End With
End Sub
Why use copy and paste? I try to avoid copy and paste because it relies on the OS's clipboard which can be used by other applications.
Worksheets("Sheet1").Columns(j).value = Columns(j).value
also this:
Application.CountIfs
should be this:
Application.worksheetfunction.CountIf 'Note, don't need countifS for only 1 criteria
Also, not sure that you really need to convert it to a boolean.
I'm trying to make a macro that will scroll through a spreadsheet an entire row at a time and merge all cells in the active row if they have data. It should do this until the last row.
The code currently sees all rows as empty and therefor skips them, I need an if condition or do until statement that will help detect and skip empty rows, detect rows with data and merge their cells and stop entirely when it reaches the last row.
My current code:
Sub merge()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
For i = 1 To LastRow
If Range("A" & i).Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Next i
End Sub
I have also tried:
sub merge2()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
Do Until ActiveCell.EntireRow > LastRow
'this line below was a concept
If ActiveCell.EntireRow & ActiveCell.Column.Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Loop
End Sub
This is untested but should do what you want.
Option Explicit
Sub merge()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column > 1 Then
ws.Rows(i & ":" & i).merge
End If
Next i
End Sub
This If will test for a) whether the cell in column A is empty and b) whether there are any other cells in that row. if statement a evaluates to false AND statement b is greater than 1 it will execute the If statement
#Tom I've taken your code and added in an error handler that makes it work without fault, thank you very much for your patience, you've been a fantastic help.
Sub merge2()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column >= 1 Then
On Error Resume Next
ws.Rows(i & ":" & i).merge = True
End If
Next i
End Sub