I have a problem with below code. I would like to filter "OS" (filed 61) then if first cell in 1st column below filters is not empty macro should go to first cell below filters in column "57", check if value in that cell is > 365 if yes it should go to column 62 in the same row and put there "overdue" if no then put there "OK". After that it should go to next row and check the same till the end of the filtered rows.
The problem is with visible only cells. Macro is doing it on all rows even not visible.
It should work only for filtered visible rows. Any suggestions?
Sub Patch_Overdue()
Dim i As Long
Dim LastRow As Long
Sheets("Sheet1").Select
'filter AIX OS
Selection.Autofilter Field:=61, Criteria1:="AIX*"
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 61).Select
If IsEmpty(Selection) = False Then
LastRow = Range("a7").End(xlDown).Row
For i = 1 To LastRow
If ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 57).Value > 365 Then
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 62).Select
ActiveCell.FormulaR1C1 = "Overdue"
Else
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 62).Select
ActiveCell.FormulaR1C1 = "OK"
End If
Next i
Else
ActiveSheet.ShowAllData
End If
End Sub
Please, try the next code. It is not tested, but it should work. Basically, it set the range to be processed based on the last cell in A:A and UserRange number of columns, extract the visible cells range, iterate between its areas and the between each area rows and check what you need:
Sub Patch_Overdue()
Dim sh As Worksheet, rngUR As Range, rngVis As Range, i As Long, LastRow As Long
Set sh = Sheets("Sheet1")
If sh.AutoFilterMode Then sh.AutoFilterMode = False 'eliminate a previous filter to correctly calculate last row
LastRow = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
'filter AIX OS
Set rngUR = sh.Range("A7", sh.cells(LastRow, sh.UsedRange.Columns.count)) 'set the range to be filtered
rngUR.AutoFilter field:=61, Criteria1:="AIX*" 'filter the range according to criteria
Set rngVis = rngUR.Offset(1).SpecialCells(xlCellTypeVisible) 'set the visible cells range
Dim arRng As Range, r As Range
For Each arRng In rngVis.Areas 'iterate between the range areas:
For Each r In arRng.rows 'iterate between the area rows:
If WorksheetFunction.CountA(r) > 0 Then 'for the case of the last row which is empty because of Offset
If r.cells(1, 57).value > 356 Then
r.cells(1, 62).value = "Overdue"
Else
r.cells(1, 62).value = "OK"
End If
End If
Next
Next
sh.ShowAllData
End Sub
Related
Hi im trying to create a function in VBA which scans the top row and inserts a filter on a particular cell in the third row if the corresponding cell in the top row contains a value, if a cell is empty then it should skip to the next cell. The third row will be a header row.
Here is some code:
Sub FilterRefresh()
Dim i As Long, lastCol As Long
Dim rng As Range, cell As Range
Dim wSheet As Worksheet
Set wSheet = Worksheets("Machining")
'find the last column in row one
lastCol = wSheet.Cells(1, Columns.Count).End(xlToRight).Column 'xlToLeft
'set range from A1 to last column
Set rng = wSheet.Range(Cells(1, 1), Cells(1, lastCol)) 'will be a higher cell range
'Outline the autofilter field hierarchy
i = 1
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.row + 2, i + 1).AutoFilter Field:=i, Criteria1:=cell.Value
i = i + 1
End If
Next cell
End Sub
Try this:
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter Field:=cell.Column, Criteria1:=cell.Value
End If
Next cell
I want to filter column B based on values like "Unknown", then filter L column to have un-null values. copy the L column.
Paste values only to the column B.
Before:
ColumnB ..... Column L
1 ..... a
2 ..... b
Unknown.c
3.......d
Unknown.e
Unknown.
After
1 ..... a
2 ..... b
c.......c
3.......d
e.......e
Unknown..
Set r1 = Range("B:B").SpecialCells(xlCellTypeVisible)
Set r2 = Range("L:L").SpecialCells(xlCellTypeVisible)
Set myMultipleRange = Union(r1, r2)
Application.ScreenUpdating = False
sh1.Range("B:L").AutoFilter
sh1.Range("B:B").AutoFilter Field:=1, Criteria1:="Unknown", Operator:=xlFilterValues
sh1.Range("L:L").AutoFilter Field:=11, Operator:=xlFilterValues, Criteria1:="<>"
LstRw = sh1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If LstRw <> 0 Then
myMultipleRange.FillLeft
End If
The above code will copy and paste including the format.
Copy/paste in a filtered table is no good idea, because it inserts data continously even in hidden rows and messes up your data.
I recommend the following:
Filter data
Loop through all visible cells and copy the data row by row
If the following data is given …
… and you want to replace unkown with the data in column L, you can do the following:
Option Explicit
Public Sub FilterAndCopy()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Tabelle1")
'Filter data
ws.Range("B:B").AutoFilter Field:=1, Criteria1:="Unknown", Operator:=xlFilterValues
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DestinationRange As Range
On Error Resume Next 'next line throws error if filter returns no data rows
Set DestinationRange = ws.Range("B2", "B" & LastRow).SpecialCells(xlCellTypeVisible) 'find visible cells between B2 (exclude header) and last row in B
On Error GoTo 0 'always re-activate error reporting!
If Not DestinationRange Is Nothing Then 'do it only if there is visible data
Dim Cell As Range
For Each Cell In DestinationRange 'copy each value row wise
Cell.Value = Cell.Offset(ColumnOffset:=10).Value 'column L is 10 columns right of B
Next Cell
End If
End Sub
Alternative solution - simply go through each cell in column B and replace "Unknown" with a respective value in column L.
Sub foo()
Dim lngLastRow As Long
Dim rngCell As Range
With Sheet1
LastRow = .Range("B" & Rows.Count).End(xlUp).Row
For Each rngCell In .Range("B1:B" & LastRow)
If rngCell.Value = "Unknown" Then
rngCell.Value = .Range("L" & rngCell.Row).Value
End If
Next rngCell
End With
End Sub
P.S. Make sure to replace With Sheet1 statement with a relevant sheet name/code.
This is what I have so far. There are a couple of amendments I want to make, that I don't completely understand how to do;
On line 3, I want my 'Copying criteria' to be 'Greater than 50000' or 'Less than 50000'.
How can I specify the cells on Sheet2 where the first item is copied to? For example, Sheet2! B10?
How can I then restrict the columns copied from the row on Sheet 1 which meets my criteria to (for example) columns A, B, E, F, H, I, O, & AG from Sheet1?
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(x1Up).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 3).Value = **>50000 OR <50000** Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets("Sheet2").Activate
b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(x1Up).Row
Worksheets("Sheet2").Cells(b + 1, 1).Select
ActivateSheet.Paste
Worksheets("Sheet1").Activate
End if
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
End Sub
you could use Abs() function and have one check only:
and use Range property of Worksheet object to select wanted columns in given row by means of Intersect() method:
Option Explicit
Sub main()
Dim a As Long, i As Long
Dim sht2 As Worksheet
Set sht2 = Worksheets("Sheet2") ' set a worksheet object for destination sheet
With Worksheets("Sheet1") ' reference Sheet1
a = .Cells(.Rows.Count, 1).End(xlUp).Row ' get referenced sheet column A row index of last not empty cell
For i = 2 To a
If Abs(.Cells(i, 3).Value) > 50000 Then ' if cell value in current row index and column 3 is greater than 50000 or less then -500000
Intersect(.Rows(i), .Range("A:B , E:F, H:I, O:O, AG:AG")).Copy
sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial
Application.CutCopyMode = False
End If
Next
End With
End Sub
You are using x1Up instead of xlUp.
Application.ScreenUpdating = False
Dim cell As Range
With Worksheets("Sheet1")
For Each cell In .Range("A2", .Cells(Rows.Count, 1).End(xlUp)).Offset(0, 2)
If cell.Value > -50000 Or cell.Value < 50000 Then
With Worksheets("Sheet2")
cell.EntireRow.Range("A1:B1,E1:F1,H1,I1,O1,AG1").Copy Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
End If
Next
End With
I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.
The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.
There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.
Below is the code:
Sub copyrows()
Dim tfRow As Range, cell As Object
Set tfRow = Range("A1:A") 'Range which includes the values
For Each cell In tfRow
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P2").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Sub copyrows2()
Dim tfRow2 As Range, cell As Object
Set tfRow2 = Range("A1:A") 'Range which includes the values
For Each cell In tfRow2
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P5").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
As #urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.
To merge two conditions, in your case add an Or to your If.
To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function.
Read HERE about the Union functionality.
More comments inside the code's notes below.
Modified Code
Option Explicit
Sub copyrows()
Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long
Set Sht1 = Sheet1
Set Sht3 = Sheet3
With Sht1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A
Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values
For Each C In tfRow
If IsEmpty(C) Then
Exit Sub
End If
If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, C) ' use Union to merge multiple ranges
Else
Set CopyRng = C
End If
End If
Next C
End With
' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
' get last row with data in "sheet3"
LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row
CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If
End Sub
I am trying to write a macro that hides the row if the cell value equals the next visible cell in that column and loops through the whole column. I have read that SpecialCells(xlCellTypeVisible) only works up to 8192 cells and my spreadsheet has 15,000 rows.
I have tried something like this but want to restrict it to only visible cells
Sub Test()
For i = 7 To 15258
If Range("P" & i).Value = Range("P" & i + 1).Value Then
Rows(i).Hidden = True
End If
Next i
End Sub
I have tried to search for a solution but haven't been able to find one yet.
Thanks!
I'd be surprised if this couldn't be optimized just a little bit, but it will work for what you are needing.
You can follow the comments within the code itself to kind of get a sense of what it's doing, but in a nutshell, you are using a For...Next statement to loop through your visible cells. For each visible cell, you will search for the next visible cell and then check to see if that matches. If it does, you add that cell to a special range that tracks all the rows to hide at the end of the code, then hide it.
Sub Test()
Dim ws As Worksheet, lookupRng As Range, rng As Range, lstRow As Long
Set ws = ThisWorkbook.Worksheets(1)
lstRow = 15258
Set lookupRng = ws.Range("P7:P" & lstRow)
Dim rngToHide As Range, i As Long
For Each rng In lookupRng.SpecialCells(xlCellTypeVisible)
Application.StatusBar = "Checking row " & rng.Row & " for matches."
For i = rng.Row + 1 To lstRow 'Loop through rows after rng
If Not ws.Rows(i).Hidden Then 'Check if row is hidden
If rng.Value = ws.Cells(i, "P") Then 'check if the non-hidden row matches
If rngToHide Is Nothing Then 'Add to special range to hide cells
Set rngToHide = ws.Cells(i, "P")
Else
Set rngToHide = Union(rngToHide, ws.Cells(i, "P"))
End If
End If
Exit For 'Exit the second For statement
End If
Next i
Next rng
Application.StatusBar = "Hiding duplicate rows"
If Not rngToHide Is Nothing Then rngToHide.EntireRow.Hidden = True
Application.StatusBar = False
End Sub