I'm trying to create a function that inserts a filter within a cell range if a cell contains a value
Sub FilterFunc()
Dim i As Long, lastCol As Long
Dim rng As Range, cell As Range
Dim wSheet As Worksheet
Set wSheet = Worksheets("Sheet1")
'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))
'Outline the autofilter field hierarchy
i = 1
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
End Sub
At the moment when the following code is executed:
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter
Field:=cell.Column, Criteria1:=cell.Value
It returns Runtime error: 1004 Autofilter Method of Range class failed
Its probably something silly but im trying to figure out where im going wrong
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 am processing a data set that has about 50 columns, and the same columns are always off by a factor of ten. So, I just want to hardcode the specific columns (starting with F here) and divide every cell in the column by 10. Right now I am getting a "Type Mismatch" error. The code is below:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
cell.Value = cell.Value / 10
Next cell
End Sub
why loop when you can simply paste special and divide.
errors within the cells are ignored.
in vba, here is the code
Range("G10").Copy
Range("B2:E8").PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide
Application.CutCopyMode = False
test if cell is an error and then test if it is a number prior to dividing:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
If Not IsError(Cell) Then
If IsNumeric(cell) and cell <> "" Then
cell.Value = cDbl(cell.Value) / 10
End If
End If
Next cell
End Sub
i am stuck with my procject again... I tried with formulas but i can t make it work or i can t make it right, and i couldn t find similar topic any where, here is the problem. As u can see in screenshot in this link https://ibb.co/FJRBxcM i have 2 worksheets, Sheet1 with some value generator, and Sheet"RadniNalog" where i copy&paste manualy certan values from Sheet1. My goal is to make it work automatically, when i paste data from another Workbook, as shown in screenshot example, i polulate range "A10:C27", range width is constant, always 3 column, but rows can change so number is X. Now i need values from "A10:A27" to copy to next empty column from left to right in Sheet"RadniNalog" from cells in 2nd row. Next i also need to copy Value from cell =F$13$ into the first row in sheet "RadniNalog" (on screenshot example its cell "E1" and that value from F13 needs to act like a Header for values belove it. If Value from header is the same as value in cell "F13" i need to continue adding values under existing ones, and if not move to the next available column. In screenshot example, if cell "D1" from sheet "RandiNalog" is same as cell "F13" in Sheet1, then values from range "A10:A27" should be added under last value in ColumnD. I need some VBA code if possible to make it work as wanted. Thanks in advance
Copy this code to Sheet1 module
This code runs the macro copyValuesToWs when you put the code in F13
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F13:G13")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Call copyValuesToWs
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Create a new module and insert this code
Option Explicit
Function FindLastRow(ByVal Col As Byte, ws As Worksheet) As Long
FindLastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function
Function FindLastColumn(ByVal rw As Byte, ws As Worksheet) As Long
FindLastColumn = ws.Cells(rw, Columns.Count).End(xlToLeft).Column
End Function
Sub copyValuesToWs()
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Radni nalog")
Dim lCol As Long
Dim lRow As Long
Dim srcRng As Range
Dim dstRng As Range
Dim hdRng As Range
' Next row after ID
Dim idRng As Range: Set idRng = ws1.Range("A10")
' find last row value in column A
lRow = FindLastRow(1, ws1)
' range to be copied
Set srcRng = ws1.Range(ws1.Cells(idRng.Row, 1), ws1.Cells(lRow, 1))
' find last used column in sheet2
lCol = FindLastColumn(1, ws2)
' header range
Set hdRng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lCol))
' check if value exists in header
On Error Resume Next
Dim sValue As Double: sValue = Application.WorksheetFunction.Match(ws1.Range("F13").Value, hdRng, 0)
If Err.Number = 0 Then ' value exists
' find last row
Set dstRng = ws2.Cells(FindLastRow(sValue, ws2) + 1, sValue)
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
Else
' set destination range
Set dstRng = ws2.Cells(2, lCol + 1)
' set header value
ws1.Range("F13:G13").Copy
ws2.Cells(1, lCol + 1).PasteSpecial xlPasteValues
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
End If
On Error GoTo 0
Application.CutCopyMode = False
End Sub
I have this code (see below) that finds if a column in the front of a sheet must be deleted when all the columns which needed to be deleted are deleted. the code finds the last used column and refills the sheet until it reaches column DO.
But now, when the column is already filled from the last time I pressed the button and no rows got deleted. the code crashes and says
Error 1004 while executing. Methode Autofill of class Range failed.
It only works when the column DO is not used yet.
This is my code:
Dim lColumn As Long
Dim iCntr As Long
lColumn = 20
For iCntr = lColumn To 12 Step -1
If Cells(3, iCntr) = 0 Then
Columns(iCntr).Delete
End If
Next
With Workbooks("Bureauplanning2backup.xlsm").Worksheets("Planning")
Dim rngStart As Range
Set rngStart = .Cells(2, .Columns.Count).End(xlToLeft).Offset(,
-1).EntireColumn
Dim rngEnd As Range
Set rngEnd = .Cells(2, .Columns.Count).End(xlToLeft).EntireColumn
Dim rng As Range
Set rng = .Range(rngStart, .Columns("DO"))
Dim rngX As Range
Set rngX = .Range(rngStart, rngEnd)
End With
rngX.AutoFill rng, Type:=xlFillDefault
Is there a way to check if column DO is already filled and when it is filled the code just does not run the line:
rngX.AutoFill rng, Type:=xlFillDefault
You can count how many cells in DO have data
If Application.WorksheetFunction.CountA(.Columns("DO")) = 0 Then
'zero cells have data so autofill
rngX.AutoFill rng, Type:=xlFillDefault
Else
'at least one cell has data so don't autofill
MsgBox "Column DO has already data"
End If
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub