The problem is that RowCount returns 1 instead of visible rows after filtering.
RowCount = Cells(Rows.Count, colIndex).End(xlUp).SpecialCells(xlCellTypeVisible).Row
Sub showEightmonth(ws, colName, colIndex)
Dim RowCount As Integer
ws.Activate
MsgBox ws.Name
RowCount = Cells(Rows.Count, colIndex).End(xlUp).Row
Set Rng = Range(colName & "1:" & colName & RowCount)
If ws.AutoFilterMode = True Then
ws.AutoFilter.ShowAllData
End If
Rng.Select
Rng.NumberFormat = "mm/dd/yyyy hh:mm:ss"
d = Format(DateAdd("m", -8, Date), "mm/dd/yyyy 07:00:00")
Range(colName & "1").AutoFilter Field:=colIndex, Criteria1:="<" & d
RowCount = Cells(Rows.Count, colIndex).End(xlUp).SpecialCells(xlCellTypeVisible).Row
'Delete filtered row if RowCount > 1, as row 1 is the header row
If RowCount > 1 Then
delRow = colName & "2:" & colName & RowCount
ActiveSheet.Range(delRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
If ws.AutoFilterMode = True Then
ws.AutoFilter.ShowAllData
End If
End Sub
To count the rows that are visible after applying a filter you would have to do this:
Sub countNonFiltered()
Dim sht As Worksheet
Dim colIndex As Long
Dim firstrow As Long
Dim RowCount As Long
Set sht = ThisWorkbook.Worksheets("worksheet name")
colIndex = 1 'let's assume you're interested in column A
firstrow = 2 'Let's assume your header is in row 1 and the data starts from row 2
With sht
RowCount = .Range(.Cells(Rows.Count, 1).End(xlUp), .Cells(firstrow, colIndex)).SpecialCells(xlCellTypeVisible).Count
Debug.Print RowCount
End With
End Sub
For demonstration purposes the code above prints the number of the visible rows in the immediate window.
Keep in mind that this:
Cells(Rows.Count, colIndex).End(xlUp)
is a range consisting of only one single cell. What you need instead is a range consisting of all the cells that belong to the rows that are still visible after applying the filter.
Also keep in mind that when you're using variables that hold either row or column indexes, they should be declared as Long.
Related
I need to auto number rows if adjacent cell is not blank using VBA.
any one from below codes works perfectly , except if it counter blank cells.
as always, your support is much appreciated.
this the expected output
Sub Fill_Serial_Numbers_Option1()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
Range("A3:A" & Application.Max(2, LastRow)) = Evaluate("ROW(A1:A" & LastRow & ")")
End If
End Sub
Sub Fill_Serial_Numbers_Option2()
Dim LastRow As Long
LastRow = Cells(Rows.count, "B").End(xlUp).Row
If LastRow > 2 Then
With Range("A3:A" & LastRow)
.Cells(1, 1).value = 1
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Trend:=False
End With
End If
End Sub
Please, test the next code:
Sub testCountNonBlanks()
Dim sh As Worksheet, lastR As Long, arr, arrA, count As Long, i As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row: count = 1
If lastR <= 2 Then Exit Sub
arr = sh.Range("B2:B" & lastR).value 'place the range in an array for faster iteration
arrA = sh.Range("A2:A" & lastR).value
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then arrA(i, 1) = count: count = count + 1
Next i
sh.Range("A2").Resize(UBound(arrA), 1).value = arrA
End Sub
If a formula (written in VBA) is allowed, you can use the next variant:
Sub testCountByFormula()
Dim sh As Worksheet, lastR As Long, rngB As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
Set rngB = sh.Range("B2:B" & lastR)
sh.Range("A2:A10").Formula = "=IF(B2<>"""",COUNTA(" & rngB.Address & ")-COUNTA(" & rngB.Address(0, 1) & ")+1,"""")"
End Sub
You don't need a macro to accomplish this. Assuming all you care about is blank or not, then you can use a formula like this in cell A9. =Counta($B$1:$B9) If you have formulas you can try to leverage something with COuntif.
You can use a loop from the first row to the last one, something like this:
Sub Fill()
Dim LastRow As Long
Dim Count As Integer
Dim Row As Integer
Count = 0
Row = 1
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Do While Row <= LastRow
If Not (Cells(Row, 2) = "") Then
Count = Count + 1
Cells(Row, 1) = Count
End If
Row = Row + 1
Loop
End Sub
I have created below code which works like IF Col"B" any cell <> "" And Col"L" any cell = "Leop" then add row below to the active cell.
I mean I'm trying to achieve is to insert single row after certain row which contain in column B any value, and if column L in same row contains value = "Leop". Then add the row after that certain row.
But an error is appear. Compile Error: Invalid use of property on xlDown
Your help will be appreciated to fix it.
From this:
to this:
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long
Dim rng As Range
Dim rng2 As Range
Dim i As Long
Dim p As Long
Dim dat As Variant
Dim datt As Variant
Dim IRow As Long
Set ws = Thisworkbooks.Sheets("Sheet2")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B2:B" & LRow)
Set rng2 = .Range("L2:L" & LRow)
dat = rng
datt = rng2
IRow = Selection.Row
For i = LBound(dat, 1) To UBound(dat, 1)
For p = LBound(datt, 1) To UBound(datt, 1)
If dat(i, 1) <> "" And datt(p, 1) = "Leop" Then
Rows(IRow + 1).Select
Selection.Insert Shift: xlDown
End If
End Sub
It will be like in formula:
IF(AND(B2<>"",L2="Leop"),"InsertRowBelow to Row 2 If condition is met","")
and will drag it down to the lastRow.
Thisworkbooks.Sheets("Sheet2") should be Thisworkbook.Sheets("Sheet2") and missing = in Selection.Insert Shift:= xlDown
Inserting or deleting rows will change the last row number so start at the bottom and work upwards.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet, LRow As Long, r As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
LRow = .Range("B" & .Rows.Count).End(xlUp).Row
For r = LRow To 2 Step -1
If .Cells(r, "B") <> "" And .Cells(r, "L") = "Leop" Then
.Rows(r + 1).Insert shift:=xlDown
n = n + 1
End If
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub
Try this with autofilter, you dont have to loop through each row. So it will work faster for larger data.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long, cl As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("L1:L" & LRow).AutoFilter 1, "Leop"
For Each cl In ws.Range("_FilterDatabase").SpecialCells(12).Cells
If ws.Range("B" & cl.Row) <> "" Then
cl.Offset(1).EntireRow.Insert Shift:=xlDown
End If
Next
ws.AutoFilterMode = False
End Sub
wht i want is if cell value in column A is 60 then cell value in the same row in column C must equal FF code below.
Sub column_check2()
Dim c As Range
Dim alastrow As Long
Dim clastrow As Long
alastrow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
clastrow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
For Each c In Range("A2:A3" & alastrow & ",C2:C3" & clastrow)
If Not c.Value = "60" And c.Value = "FF" Then
MsgBox "error" & c.Address
End If
Next c
End Sub
You just need to loop through each value in Column A and check your criteria (Cell = 60). You can then adjust the value in Column C by using Offset to navigate 2 cells to the right from the current cell in the loop
Sub Looper()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") 'Update Sheet Name
Dim lr As Long, Target As Range
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For Each Target In ws.Range("A2:A" & lr)
If Target = 60 Then
Target.Offset(0, 2) = "FF"
End If
Next Target
End Sub
Even better, consider the way you would likely do this manually. Filter Column A for your target value and then just modify the resultant cells in Column C. Recreating this in VBA results in a solution more efficient than a loop (the larger the data set, the larger the efficiency gains)
Sub Filter()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long: lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A1:A" & lr).AutoFilter Field:=1, Criteria1:=60 'Filter
ws.Range("C2:C" & lr).SpecialCells(xlCellTypeVisible).Value = "FF" 'Apply Values
ws.AutoFilterMode = False 'Remove Filter
End Sub
Part 1: Check if column B values exist in column C. If yes then change the font of the string in column B to Bold.
Part 2: I've used the code below and it worked well. Never tried it with 50k rows.
Sub matching()
LastRow = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
For x = 1 To LastRow
'Column B = Username
If Sheet1.Range("B" & x).Font.Bold = True Then Sheet1.Range("A" & x).Value = "yay"
Next x
Application.ScreenUpdating = True
End Sub
If you have to handle too many rows, is better to use Dictionary to store values of column C & use Array to store values in column B.
Notes:
Add "Microsoft Scripting Runtime" reference (Tools - References - "Microsoft Scripting Runtime")
Dictionary is case sensitive.
You may need to change the sheet name in line Set ws = ThisWorkbook.Worksheets("Sheet1") to fulfill your needs
You could try:
Option Explicit
Sub matching()
Dim ws As Worksheet
Dim dict As Scripting.Dictionary
Dim LastRowB As Long, LastRowC As Long, Count As Long, x As Long
Dim rng As Range, cell As Range
Dim arr As Variant
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set dict = New Scripting.Dictionary
Application.ScreenUpdating = False
With ws
'Find the lastrow of column B
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
'Find the lastrow of column C
LastRowC = .Cells(.Rows.Count, "C").End(xlUp).Row
'Set an array with the values in column B - We assume that values start from row 1
arr = .Range("B1:B" & LastRowB)
'Set the range of the dicitonary - We assume that values start from row 1
Set rng = .Range("C1:C" & LastRowC)
Count = 0
'Loop range and create a dictionary with th eunique values
For Each cell In rng
If Not dict.Exists(cell.Value) Then
dict.Add Key:=cell.Value, Item:=Count
Count = Count + 1
End If
Next cell
'Loop the array & bold
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1)) Then
.Range("B" & x).Font.Bold = True
End If
Next x
End With
Application.ScreenUpdating = True
End Sub
Here you go.
Sub bold()
Dim lastrow As Double
Dim cel As Range
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For Each cel In Range("B1" & ":B" & lastrow)
If Not ActiveSheet.Range("C:C").Find(cel.Value) Is Nothing Then cel.Font.bold = True
Next cel
End Sub
I'm trying to copy all rows from between two cell values and paste the values in a new column in a new worksheet. Let's say my data is structured in one excel column as such:
x
1
2
3
y
x
4
5
6
y
So I want to copy the 123 and the 456, paste them in a new worksheet in columns A and B respectively, like so:
A B
1 1 4
2 2 5
3 3 6
The code that I have working copies the data just fine, but it only pastes them below each other. Is there any way to amend the following code to paste the copied data in a new column every time the loop runs through?
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "y"
endrow = rownum - 1
rownum = rownum + 2
Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
Sheets("Sheet2").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
There's a lot going on in that code that doesn't need to. Have a look at the below and see if you can follow what's happening:
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
colnum = 1 'start outputting to this column
Dim rangetocopy As Range
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
If .Cells(rownum, 1).Value = "y" Or rownum = lastrow Then
endrow = rownum
Set rangetocopy = Worksheets("Sheet1").Range("A" & startrow & ":A" & endrow)
rangetocopy.Copy Sheets("Sheet2").Cells(1, colnum)
colnum = colnum + 1 ' set next output column
End If
Next rownum
End With
End Sub
you could use:
SpecialCells() method of Range object to catch "numeric" values range
Areas property of Range object to loop through each set of "numeric" range
as follows:
Sub CommandButton1_Click()
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
Dim area As Range
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
to manage data of any format (not only "numeric") between "x"s or "x"s and "y"s, then use
AutoFilter() method of Range object to filter data between "x"s or "x"s and "ys" "
SpecialCells() method of Range object to catch not empty values range
Areas property of Range object to loop through each set of "selected" range
as follows:
Sub CommandButton1_Click()
Dim area As Range
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd, Criteria2:="<>y"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) '.Offset(-1)
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
.AutoFilterMode = False
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
This type was already mentioned, but since I wrote it, I'll share it as well, using range areas.
This is also assuming layout is actual in the original question and that you are trying to extract a group of numbers.
Sub Button1_Click()
Dim sh As Worksheet, ws As Worksheet
Dim RangeArea As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
For Each RangeArea In sh.Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas
RangeArea.Copy ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1)
Next RangeArea
End Sub