Why does the following VBA script not show any message boxes when row 4, 5 and 6 are all empty...
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
Set myRange = Range("B" & i & ":T" & i)
If WorksheetFunction.CountA(myRange) = 0 Then
MsgBox "Empty " & Cells(i, 1).Row
Else
x = x
End If
Next
End Sub
Just test both column ranges:
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
count = WorksheetFunction.CountA(Range("B"&i & ":D"&i))
count = count + WorksheetFunction.CountA(Range("F"&i & ":T"&i))
If count = 0 Then
MsgBox "Empty " & i
End If
Next
End Sub
edit: or build a range object which contains the two column ranges, intersect that with the last row, and move this range object in the loop. This way, you don't build the range object anew in each iteration:
Sub Test()
Dim rng As Range, colrng As Range
Dim LastRow As Long
Dim i As Long
LastRow = 40
Set colrng = Application.Union(Range("B:D"), Range("F:T"))
Set rng = Application.Intersect(colrng, Rows(LastRow))
For i = LastRow To 3 Step -1
If WorksheetFunction.CountA(rng) = 0 Then
MsgBox "Empty row: " & i
End If
Set rng = rng.Offset(-1, 0)
Next
End Sub
As good practice, always declare your variables, and use long integers for row or column indices.
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
Set myRange = Range("B" & i & ":T" & i)
If WorksheetFunction.CountIf(myRange,"<>") = 0 Then 'count where it's not a null or empty string
MsgBox "Empty " & Cells(i, 1).Row
Else
x = x
End If
Next
End Sub
The only way I can seem to do it is a slow way:
LastRow = Range("B:Z").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For i = LastRow To 3 Step -1
BlankRow = False
For j = 2 To LastColumn
If Cells(i, j).Value <> "" Then
Blank = False
Exit For
End If
BlankRow = True
Next j
If BlankRow = True Then
x = x
End If
Next i
Related
can anyone advise how can I turn RowIncrement = 2 into a "loop" that goes and pick ups the values from a column based on the other sheet? So, if the first value in the column is 1 then RowIncrement = 1, then it goes to the next value in that column, which may be e.g. 6 and then RowIncrement = 6 and so on.
Sub EmptyRowEveryX()
Dim NumRowsToInsert As Long
Dim RowIncrement As Long
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim LastEvenlyDivisibleRow
Dim i As Long
Dim z As Long
Dim HowMany As Integer
NumRowsToInsert = 1
RowIncrement = 2
Set ws = ActiveSheet
For n = LastRow To 1 Step -1
HowMany = Range("BM" & z)
If (HowMany > 1) Then
Rows(z & ":" & HowMany).Insert Shift:=xlDown
End If
With ws
LastRow = .Range("AZ" & .Rows.count).End(xlUp).Row
LastEvenlyDivisibleRow = Int(LastRow / RowIncrement) * RowIncrement
If LastEvenlyDivisibleRow = 0 Then
Exit Sub
End If
For i = LastEvenlyDivisibleRow To 1 Step -RowIncrement
.Range(i & ":" & i + (NumRowsToInsert - 1)).Insert xlShiftDown
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub OneEmptyRow()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Range("AZ1", Range("AZ" & Rows.count).End(xlUp))
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.Offset(, -1).AutoFilter Field:=1, Criteria1:="=*total*"
.Offset(2).SpecialCells(xlCellTypeVisible).ClearContents
.AutoFilter
.Offset(, -1).EntireColumn.Delete
.EntireColumn.RemoveSubtotal
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I am trying to delete the contents of duplicate cells in a single column. I want to keep the first occurrence of the entry, but remove all duplicates below it.
I could only find code that deletes the entire row and not clear the contents.
Sub Duplicate()
With Application
' Turn off screen updating to increase performance
.ScreenUpdating = False
Dim LastColumn As Integer
LastColumn = Cells.Find(What:="*", After:=Range("U1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
With Range("U1:U" & Cells(Rows.Count, 1).End(xlUp).Row)
' Use AdvanceFilter to filter unique values
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
.SpecialCells(xlCellTypeVisible).Offset(0, LastColumn - 1).Value = 1
On Error Resume Next
ActiveSheet.ShowAllData
'Delete the blank rows
Columns(LastColumn).SpecialCells(xlCellTypeBlanks).Cells.Clear
Err.Clear
End With
Columns(LastColumn).Clear
.ScreenUpdating = True
End With
End Sub
Here is one way. We start at the bottom of a column and work upwards:
Sub RmDups()
Dim A As Range, N As Long, i As Long, wf As WorksheetFunction
Dim rUP As Range
Set A = Range("A:A")
Set wf = Application.WorksheetFunction
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 2 Step -1
Set rUP = Range(Cells(i - 1, 1), Cells(1, 1))
If wf.CountIf(rUP, Cells(i, 1).Value) > 0 Then Cells(i, 1).Clear
Next i
End Sub
We check above to see if there are any duplicates above us and clear the cell if yes. Before:
and after:
EDIT#1:
For column U:
Sub RmDupsU()
Dim U As Range, N As Long, i As Long, wf As WorksheetFunction
Dim rUP As Range
Set U = Range("U:U")
Set wf = Application.WorksheetFunction
N = Cells(Rows.Count, "U").End(xlUp).Row
For i = N To 2 Step -1
Set rUP = Range(Cells(i - 1, "U"), Cells(1, "U"))
If wf.CountIf(rUP, Cells(i, "U").Value) > 0 Then Cells(i, "U").Clear
Next i
End Sub
my 0.02 cents
Sub main()
Dim i As Long
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
For i = 1 To .Rows.Count - 1
.Range(.Cells(i + 1, 1), .Cells(.Rows.Count)).Replace what:=.Cells(i, 1).Value, replacement:="", lookat:=xlWhole
Next i
End With
End Sub
Here is a routine that will work. It can be sped up considerably if necessary:
EDIT: I changed column number to column letter, where you would need to make changes if you want a column other than "A"
Option Explicit
Sub ClearDups()
Dim R As Range
Dim I As Long
Dim COL As Collection
Set R = Range(Cells(1, "A"), Cells(Rows.Count, "A").End(xlUp))
Set COL = New Collection
On Error Resume Next
For I = 1 To R.Rows.Count
COL.Add Item:=R(I, 1), Key:=CStr(R(I, 1))
Select Case Err.Number
Case 457 'Duplicate test (Collection object rejects duplicate keys)
Err.Clear
R(I, 1).ClearContents
Case Is <> 0 'unexpected error
MsgBox Err.Number & vbLf & Err.Description
End Select
Next I
On Error Goto 0
End Sub
'This code crisply does the job of clearing the duplicate values in a given column
Sub jkjFindAndClearDuplicatesInGivenColumn()
dupcol = Val(InputBox("Type column number"))
lastrow = Cells(Rows.Count, dupcol).End(xlUp).Row
For n = 1 To lastrow
nval = Cells(n, dupcol)
For m = n + 1 To lastrow
mval = Cells(m, dupcol)
If mval = nval Then
Cells(m, dupcol) = ""
End If
Next m
Next n
End Sub
My function is always returning 0 when called in a worksheet but returns proper values when called through a sub.
This function searches through a worksheet (sheetname) to see if the input value can be found in any of the columns, and if so returns the value in row 1 of the column.
'test sub
Sub test()
MsgBox custCat("SUNTRUST BANK")
End Sub
Public Function custCat(toSearch)
Dim sheetName As String
sheetName = "LookupValues"
Dim i As Integer
i = 1
Dim lastRow As Integer
Dim colLtr As String
Dim j As Integer
'find last column
Dim lastColumn As Integer
lastColumn = Worksheets(sheetName).Range("A1").SpecialCells(xlCellTypeLastCell).Column
'loop through columns
Do While i <= lastColumn
'find last row
lastRow = Worksheets(sheetName).Cells(Worksheets(sheetName).Rows.Count, i).End(xlUp).Row
'search through column
j = 2
Do While j <= lastRow
If InStr(UCase(toSearch), UCase(Worksheets(sheetName).Cells(j, i).Value)) > 0 Then
If custCat = "" Then
custCat = Worksheets(sheetName).Cells(1, i).Value
Else
custCat = custCat & ", " & Worksheets(sheetName).Cells(1, i).Value
End If
j = lastRow 'exit loop if found
End If
j = j + 1
Loop
i = i + 1
Loop
End Function
I cleaned up the code a bit and made a few adjustments, try this:
Public Function custCat(toSearch)
Dim i&, j&, lastRow&, lastColumn&
Dim ws As Worksheet
Set ws = Worksheets("LookupValues")
With ws
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
i = 1
'loop through columns
Do While i <= lastColumn
'find last row
lastRow = .Cells(.Rows.Count, i).End(xlUp).Row
'search through column
j = 2
Do While j <= lastRow
If InStr(UCase(toSearch), UCase(.Cells(j, i).Value)) > 0 Then
If custCat = "" Then
custCat = .Cells(1, i).Value
Else
custCat = custCat & ", " & .Cells(1, i).Value
End If
Exit Do 'exit loop if found
End If
j = j + 1
Loop
i = i + 1
Loop
End With
End Function
The below code works great for copying an entire row, how do I make it so I only copy over the first column.
I have tried altering range with no success? Condition is in J, the only column to copy should be 1st one.
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cell.EntireRow.Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Many thanks!
try
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cells(cell.row,1).Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cell.End(xlToLeft).Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Just switch EntireRow to EntireColumn, it is as simple as that! ;)
Dim rCell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each rCell In Sheets(1).Range("J1:J" & lastRow)
If rcell.Value = 1 Then
rcell.EntireColumn.Copy Sheets(5).Cells(1, i)
i = i + 1
End If
Next rCell
I would like to with this macro delete all cells after last empty row until the line where in column "E" is "Total"
I've tried this, but there is error on loop line:
Sub delete()
Dim r As Range
Dim lastRow As Long
Dim c As Range
Dim i As Long
i = lastRow + 1
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Do
Set r = Range("B" & i)
If Len(r) = 0 Then r.EntireRow.delete
i = i + 1
Loop Until Cells(i, 5).Value = "Total"
End Sub
And here is the example how my table look like:
I'd use something like the following which will continue through all cells until E&i = total:
Public Sub Delete()
Dim i As Long
i = 2 'Start from row 2
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
Do Until .Range("E" & i).Value = "Total"
If .Range("B" & i).Value = vbNullString Then
.Rows(i).EntireRow.Delete
Else
i = i + 1 'Only increment if the row hasn't been deleted to prevent skipping rows
End If
Loop
End With
Application.ScreenUpdating = True
End Sub