Below is the code that I came up with, however, the issue lies in the 3rd line wherein the filtered data does not necessarily start in row 2. If the first data point satisfying the criteria is located at row 150, then it would return an error:
Total_Rows_Compiled = Worksheets("Compiled").Range("A" & Rows.Count).End(xlUp).Row
Worksheets("Compiled").Range("$A$1:$G$52818").AutoFilter Field:=1, Criteria1:=Worksheets("Sheet1").Cells(l, 1)
Worksheets("Compiled").Range("A2:G" & Total_Rows_Compiled).SpecialCells(xlCellTypeVisible).Select
There doesn't appear to be anything substantially wrong with your code. With that in mind, the following is a combination of methods that I have found to be reasonably error free.
with Worksheets("Compiled")
.activate
if .autofiltermode then .autofiltermode = false
Total_Rows_Compiled = .Range("A" & .Rows.Count).End(xlUp).Row
with .range("A1:G" & Total_Rows_Compiled)
.AutoFilter Field:=1, Criteria1:=Worksheets("Sheet1").Cells(l, 1)
with .resize(.rows.count-1, .columns.count).offset(1, 0)
if cbool(application.subtotal(103, .cells)) then
.SpecialCells(xlCellTypeVisible).Select
end if
end with
end with
end with
You could loop through the Areas:
Dim filterRange As Range, filteredRange As Range, area As Range
Set filterRange = Worksheets("Compiled").Range("$A$1:$G$52818")
filterRange.AutoFilter Field:=1, Criteria1:=Worksheets("Sheet1").Cells(l, 1)
Set filteredRange = Intersect(filterRange, filterRange.Offset(1, 0)).SpecialCells(xlCellTypeVisible) 'remove headers
If Not filteredRange Is Nothing Then
For Each area In filteredRange.Areas
'do something with area
Debug.Print area.Address
Next area
End If
The following data, when filtered on "test", returns the ranges (areas) B2:F2 and B4:F5 as required
Related
First things first. I am very new to VBA.
Secondly, I googled my ass of and I honestly don't get to the bottom of it. Mostly because the code is adapted to my needs based on googleing i did (copy/paste of code).
To my problem. I have a sheet(Raw Data) with lots of columns(A:AN) and lots of rows(160000) that gets updated every now and then. I want to filter the dataset based on the criteria from a few columns(A & B), and the copy/paste the data in a different sheet(Scatter Raw) starting from column A. I also do not want to copy the header from "Raw Data" and start pasting in "Scatter Sheet" also below the header -> in this case 2 rows.
I have two issues for now:
Based on the filters I do, I will get 17267 rows in "Raw Data". If I simply do a select and copy then I copy only the filtered data. But the moment I paste the data somehow I suddenly get 18362 rows, even though they are empty. I can see this by the fact that the scroll bar goes down. I used this way of copying because sometimes I want to be able to append the copied data based on value set in a different cell. What am I doing here wrong, or what is happening?
I have more sheets inside the workbook. If I do not have the Raw Data worksheet selected I get an error like "Application-defined or object-defined error" on the "Set rng = " line which I don't get. In other test I also got a different error, but that was because the Range was based on the active sheet and not the one I needed. Why is this happening, since the filters are correctly set?
The values from column N should all be divided by 1000. I guess I have no other way then using a temporary copy column, divide it by 1000 in a new column and then copy/paste the new values to the location I need in, right?
Just one last mention, the code is running in a Module and will be later assigned to a button.
Sub Copy()
Dim destTrSheet As Worksheet
Dim sctrSheet As Worksheet
Set destTrSheet = ThisWorkbook.Worksheets("Data Raw")
Set sctrSheet = ThisWorkbook.Worksheets("Scatter Raw")
With destTrSheet
.Range("A:A").AutoFilter field:=1, Criteria1:="VF", Operator:=xlFilterValues
.Range("B:B").AutoFilter field:=2, Criteria1:="CITY", Operator:=xlFilterValues
Set Rng = .Range("N2").Resize(Cells(Rows.count, "N").End(xlUp).Row - 1)
Rng.Copy
sctrSheet.Range("A" & Rows.count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Set Rng = .Range("X2").Resize(Cells(Rows.count, "N").End(xlUp).Row - 1)
Rng.Copy
sctrSheet.Range("B" & Rows.count).End(xlUp).Offset(2, 0).PasteSpecial (xlPasteValues)
End With
End Sub
The issues you mentioned
Discrepancy between manual copy and code copy could be caused by the offsets used:
Col A .Offset(1, 0).PasteSpecial - 1 row below last used row
Col B .Offset(2, 0).PasteSpecial - 2 rows below last used row
The error is caused by .Range("N2") vs (Cells(Rows.count, "N")
.Range("N2") is explicitly qualified because of the dot (.) - refers to "Data Raw"
Cells(Rows.count, "N") is implicitly referring to ActiveSheet (missing .)
If column N should be divided by 1000
Yes, a helper column can be used, as in the code bellow
Another way: copy the column to an array, divide each value, then paste it back
If column N contains strings, the division will generate cell errors:
Option Explicit
Public Sub CopyRawToScatter()
Dim wsR As Worksheet: Set wsR = ThisWorkbook.Worksheets("Data Raw")
Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
Dim lrR As Long: lrR = wsR.Cells(wsR.Rows.Count, "A").End(xlUp).Row
Dim lrS As Long: lrS = wsS.Cells(wsS.Rows.Count, "A").End(xlUp).Row + 1
With wsR
Dim fRng As Range: Set fRng = .Range(.Cells(1, "A"), .Cells(lrR, "B"))
Dim rngN As Range: Set rngN = .Range(.Cells(2, "N"), .Cells(lrR, "N"))
Dim rngX As Range: Set rngX = .Range(.Cells(2, "X"), .Cells(lrR, "X"))
Dim cRng As Range: Set cRng = Union(rngN, rngX)
End With
Application.ScreenUpdating = False
fRng.AutoFilter field:=1, Criteria1:="VF", Operator:=xlFilterValues
fRng.AutoFilter field:=2, Criteria1:="CITY", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
cRng.Copy
wsS.Cells(lrS, "A").PasteSpecial xlPasteValues
With wsS
Dim vis As Long: vis = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim lcS As Long: lcS = .Cells(lrS, "A").End(xlToRight).Column + 1
Dim divA As Range: Set divA = .Range(.Cells(lrS, "A"), .Cells(vis, "A"))
Dim divX As Range: Set divX = .Range(.Cells(lrS, lcS), .Cells(vis, lcS))
divX.Formula = "=" & .Cells(lrS, 1).Address(RowAbsolute:=False) & " / 1000"
divA.Value2 = divX.Value2
divX.ClearContents
End With
End If
wsR.UsedRange.AutoFilter
Application.ScreenUpdating = False
End Sub
Other issues
Potential conflict between your Sub name (Copy()) with the built-in Range.Copy Method
The 2 AutoFilter lines are invalid
.Range("A:A").AutoFilter field:=1, Criteria1:="VF", Operator:=xlFilterValues
.Range("B:B").AutoFilter field:=2, Criteria1:="CITY", Operator:=xlFilterValues
If your code works you probably modified it when posting the question; they should be
.Range("A:B").AutoFilter field:=1, Criteria1:="VF", Operator:=xlFilterValues
.Range("A:B").AutoFilter field:=2, Criteria1:="CITY", Operator:=xlFilterValues
You don't need brackets for .PasteSpecial (xlPasteValues)
I have this big excel file that is automated to do some processes. Today, I figured there is an issue with one of the columns and I need to fix it. to fix it I am generated this code below to filter column N to show all '#N/A'. with the filtered rows, I want to check and see if the offset to the right 2 columns has the value "Available". if it does, I want to loop through all column N and replace the '#N/A' with 'Unkown'. but the code I generated only works for the first filtered cell and doesn't loop.
Sub tess()
ActiveSheet.Range("$C$1:$AR$468").AutoFilter Field:=12, Criteria1:="#N/A"
ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(, 12).Select
Dim lr
lr = ActiveSheet.UsedRange.Rows.CountLarge
For Each cell In Range("n1:n" & lr)
If ActiveCell.Value = CVErr(xlErrNA) And ActiveCell.Offset(, 2).Value = "Available" Then
ActiveCell.Value = "Unkown Person"
End If
Next cell
End Sub
Thank you.
you can avoid looping by adding another filter:
Sub tess()
With ActiveSheet.Range("$C$1:$AR$468")
.AutoFilter Field:=12, Criteria1:="#N/A"
.AutoFilter Field:=14, Criteria1:="Available"
If Application.WorksheetFunction.Subtotal(103, .Columns(12)) > 1 Then .Offset(1, 11).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).Value = "Unkown Person"
.Parent.AutoFilterMode = False
End With
End Sub
You should refer to "cell" within your For loop, not "ActiveCell".
I'm very new to VBA and have been using the Macro recorder to create Macros. The Macro recorder can only take me so far, I'm able to accomplish 2/3 of what I need done.
I'm trying to create a Macro where I need criteria met in three Columns, copy the row that meets the criteria, and paste it onto a workbook. The criteria are "Open" "Critical" and "Date."
Here's the tricky part, the date either needs to be greater than a specific date, either through user input or referencing a cell in a third worksheet. There are a few thousand rows, and about 19 columns, and all the codes I've attempted lead to crashing excel.
Sample of the code to getting the first two criteria:
Sheets("Sheet1").Select
ActiveSheet.ListObjects("Table_owssvr").Range.AutoFilter Field:=12, _
Criteria1:="Open"
ActiveSheet.ListObjects("Table_owssvr").Range.AutoFilter Field:=16, _
Criteria1:="Critical"
Range("Table_owssvr").Select
Range("Q83").Activate
Selection.Copy
Sheets("Sheet2").Select Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
A-----------------------------------------------------------------B-----------------------------------------------------------C
Open -------------------------------------------------------Critical--------------------------------------------------1/25---Open-------------------------------------------------------High------------------------------------------------------3/25
Closed----------------------------------------------------Critical----------------------------------------------------3/24
Open------------------------------------------------------Critical-----------------------------------------------------1/25
Any help would be great!
If you are going to be writing VBA you will have to eventually stop relying on .Select. Recorded code is fine short term but it is typically verbose and inefficient.
Option Explicit
Sub wqewqwew()
Dim col1 As Long, col2 As Long, col3 As Long, dt As Date
Dim ws2 As Worksheet
Set ws2 = Worksheets("sheet2")
With Worksheets("sheet1").ListObjects("Table_owssvr")
With .HeaderRowRange
col1 = Application.Match("open", .Cells, 0)
col2 = Application.Match("critical", .Cells, 0)
col3 = Application.Match("date", .Cells, 0)
dt = CDate(Application.InputBox(prompt:="greater then when?", Title:="pick date", Default:=Date))
End With
With .Range
.AutoFilter
.AutoFilter field:=col1, Criteria1:="open"
.AutoFilter field:=col2, Criteria1:="critical"
.AutoFilter field:=col3, Criteria1:=">" & dt
End With
With .DataBodyRange
If CBool(Application.Subtotal(103, .Cells)) Then
.Copy Destination:=ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
End With
With .Range
'turn off filters
.AutoFilter
End With
End With
End Sub
You will likely want to research error control and add some to the above.
Recommended reading: How to avoid using Select in Excel VBA.
I designed it this way.
Try it.
The complete file is below the link
Download File
Sheet1 : It's your row data and click function button
Sheet2 : It's mapping data according to "Open" & "Critical" & "Date"
(The "Date" entered according to Sheet3)
Sheet3 : Enter the date you want
The complete code is as follows
Option Explicit
Private Sub Click_Click()
Dim i As Integer
For i = 2 To Worksheets("Sheet1").Range("A65536").End(xlUp).Row
If Worksheets("Sheet1").Range("A" & i) = "Open" And _
Worksheets("Sheet1").Range("B" & i) = "Critical" And _
Worksheets("Sheet1").Range("C" & i) > Worksheets("Sheet3").Range("A2") Then
Worksheets("Sheet1").Rows(i).Copy Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Next
End Sub
I am a newcomer to vba/excel macros and need a more efficient way to run the below code. I am using a for each loop to return a value from a row based on a column's value (same row). The code works, but takes far too much processing power and time to get through the loops (often freezing the computer or program). I would appreciate any suggestions...
'The following is searching each cell in a range to determine if a cell is not empty. If the cell is not empty, the macro will copy the value of the cell and paste it in to another worksheet (same row)
Set rng = Worksheets("Demographic").Range("AU2:AU" & lastRow)
i = "2"
For Each cell In rng
If Not IsEmpty(cell.Value) Then
Sheets("Demographic").Range("AU" & i).Copy
Sheets("Employee import").Range("F" & i).PasteSpecial xlPasteValues
End If
i = i + 1
Next
'The following is searching each cell in a range to determine if a cell contains a "T". If the cell contains a "T", the macro will copy the value of a different column (same row) and paste it in to another worksheet (same row)
Set rng = Worksheets("Demographic").Range("AM2:AM" & lastRow)
i = "2"
For Each cell In rng
If cell.Value = "T" Then
Sheets("Demographic").Range("AO" & i).Copy
Sheets("Employee import").Range("G" & i).PasteSpecial xlPasteValues
End If
i = i + 1
Next
A formula array should be your best hope. This supposes that the cells that do not match will lead to empty values in the destination range:
chk = "Demographic!AU2:AU" & lastRow
src = "Demographic!AU2:AU" & lastRow
With Sheets("Employee import").Range("F2:F" & lastRow)
.FormulaArray = "=IF(" & chk & "<> """"," & src & ", """")"
.Value = .Value '<-- if you want to remove the formulas and keep only the copied values
End With
chk = "Demographic!AM2:AM" & lastRow
src = "Demographic!AO2:AO" & lastRow
With Sheets("Employee import").Range("G2:G" & lastRow)
.FormulaArray = "=IF(" & chk & "= ""T""," & src & ", """")"
.Value = .Value '<-- if you want to remove the formulas and keep only the copied values
End With
Not sure that it will be faster with your dataset though, you can only verify by trying it.
If you just want a straight data transfer (ie no formulas or formats), and your data set is large, then you could consider writing the data in one batch by way of an array.
Your own code shouldn't be horrendously slow though, so it suggests you have some calculations running or maybe you're handling Worksheet_Change events. If this is possible, then you might want to disable those during the data transfer:
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Just remember to reset them at the end of your routine:
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
If you went the array route, skeleton code would be like so:
Dim inData As Variant
Dim outData() As Variant
Dim r As Long
'Read the demographic data
With Worksheets("Demographic")
inData = .Range(.Cells(2, "AU"), .Cells(.Rows.Count, "AU").End(xlUp)).Value2
End With
'Use this if your column F is to be entirely overwritten
ReDim outData(1 To UBound(inData, 1), 1 To UBound(inData, 2))
'Use this if you have exisiting data in column F
'With Worksheets("Employee import")
' outData = .Cells(2, "F").Resize(UBound(inData, 1)).Value2
'End With
'Pass the values across
For r = 1 To UBound(inData, 1)
If Not IsEmpty(inData(r, 1)) Then
outData(r, 1) = inData(r, 1)
End If
Next
'Write the new values
Worksheets("Employee import").Cells(2, "F").Resize(UBound(outData, 1)).Value = outData
as for your first copy/paste values, it actually doesn't need any check, since blank values would be pasted as blank ones...
so you could go:
With Worksheets("Demographic")
With .Range("AU2", .Cells(.Rows.count, "AU").End(xlUp))
Worksheets("Employee import").Range("F2").Resize(.Rows.count).Value = .Value
End With
End With
as for your 2nd copy/paste values, you could paste all values and then filter not wanted ones and clear them in target sheet
like follows:
With Worksheets("Demographic")
With .Range("AM2", .Cells(.Rows.count, "AM").End(xlUp))
Worksheets("Employee import").Range("G2").Resize(.Rows.count).Value = .Offset(, 2).Value
End With
End With
With Worksheets("Employee import")
With .Range("G1", .Cells(.Rows.count, "G").End(xlUp))
.AutoFilter field:=1, Criteria1:="<>T"
.Resize(.Rows.count).Offset(1).SpecialCells(xlCellTypeVisible).ClearContents
End With
.AutoFilterMode = False
End With
that said, if your workbook has many formulas and/or event handlers then you would also greatly benefit from disabling them (Application.EnableEvents = False, Application.Calculation = xlCalculationManual) before running your code and enabling them back (Application.EnableEvents = True, Application.Calculation = xlCalculationAutomatic) after you code completes
I am trying to select the first visible cell directly beneath the header of a filtered column. The code I am getting is as below, but I have to problems with this code. First, the first line of code is using the current active range of the file. It is highly likely that this file will change and this range will not be the same. How can I make it work for any file I would use it on? Second, if I use a totally different file with the same column format, the first visible cell under Column J could be J210. How can I make this work for any array of variables?
Sub Macro16()
'
' Macro16 Macro
'
'
ActiveSheet.Range("$A$1:$R$58418").AutoFilter Field:=12, Criteria1:= _
"Sheets"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[1],3)"
Selection.FillDown
End Sub
Sub FirstVisibleCell()
With Worksheets("You Sheet Name").AutoFilter.Range
Range("A" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Select
End With
End Sub
Untested but:
Sub Macro16()
With ActiveSheet.Range("A1").CurrentRegion
.AutoFilter field:=12, Criteria1:="Sheets"
If .Columns(1).SpecialCells(xlCellTypeVisible).count > 1 Then
With .Columns(10)
.Resize(.rows.count - 1).offset(1).SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RIGHT(RC[1],3)"
End With
End If
End With
End Sub
I prefer non-destructive methods of determining whether there are visible cells to work with after a filtering operation. Since you are filling in column J with a formula, there is no guarantee that column J contains any values tat can be counted with the worksheet's SUBTOTAL function (SUBTOTAL does not count rows hidden by a filter) but the formula you are planning to populate into column J references column K so there must be something there.
Sub Macro16()
With ActiveSheet
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.Columns(12).AutoFilter Field:=1, Criteria1:="Sheets"
With .Resize(.Rows.Count - 1, 1).Offset(1, 9)
If CBool(Application.Subtotal(103, .Offset(0, 1))) Then
.SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RIGHT(RC[1],3)"
End If
End With
.Columns(12).AutoFilter Field:=1
End With
End With
End Sub
Something like this might work...
Sub Macro16()
Dim ARow As Long, JRow As Long, ws1 As Worksheet
ws1 = Sheets("NAME OF SHEET WITH DATA")
ARow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("$A$1:$R$" & ARow).AutoFilter Field:=12, Criteria1:="Sheets"
JRow = ws1.Range("J" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("J" & JRow).FormulaR1C1 = "=RIGHT(RC[1],3)"
ws1.Range("J" & JRow).FillDown
End Sub