I'm using the alteration of the code from Scott Craner (which works perfectly). However, now I would like VBA to match criteria not only from one column but from 2 columns and then copy/paste as formulas to the next sheet.
Sub TransferRows()
Dim lLRow As Long
With Sheets("Sheet1")
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("B:B").AutoFilter Field:=1, Criteria1:="Cat"
.Range("B2:B" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlFormulas
.AutoFilterMode = False
End With
End Sub
Criteria1 in column "B" is "Cat", I need to add another Criteria2 ("dog") from column "C". So whenever I have "Cat" in "B" and "Dog" in "C" the entire rows are copied to Sheet2. PS. Bear in mind that I have various types of data in columns "B" and "C" so filters are imperative (also since there are 10's of thousands of rows I can't use the loop as it takes too long). Thus I would welcome advice on how to add another criteria to the aforementioned code.
Thanks
West
Try the code below (see comments inside the code):
Option Explicit
Sub TransferRows()
Dim lLRow As Long
With Sheets("Sheet1")
lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range("B1:C" & lLRow)
.AutoFilter Field:=1, Criteria1:="Cat"
.AutoFilter Field:=2, Criteria1:="dog"
End With
.Range("B2:C" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
' rest of your code goes here
End With
End Sub
Related
In column 'M' i have hundreds of rows with multiple duplicates. I only want one record to show per duplicate when i run my macro. Below is my code and it deletes all records apart from one.
Sub DeleteRows()
With ActiveSheet
Set Rng = Range("M5:M").End(xlDown)
Rng.RemoveDuplicates Columns:=1, Header:=xlYes
End With
End Sub
It starts from M5 as this is where the data is initially. Why would it only be showing one record?
Your original attempt, Range("M5").End(xlDown), is just one cell.
Your new attempt, Range("M5:M").End(xlDown), is closer but not a valid Range reference.
Try the following:
Set Rng = Range("M5:M" & Cells(Rows.Count, "M").End(xlUp).Row)
EDIT:
If you're dealing with an entire range, you need to specify the Columns argument of Range.RemoveDuplicates, something like this:
Sub RemoveDupes()
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:V" & lastRow).RemoveDuplicates Columns:=Array(13), Header:=xlYes ' column M = 13
End Sub
1. I have data in one sheet and want to filter the list of criteria in another column
2. I want to have the criteria in separate WS as well
I have included 2 separate codes below
code for same sheet list Array
Sub FilterTeams()
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("A1:H" & LastRow).AutoFilter Field:=3, Criteria1:="=*" & Range("Q1") & "*"
End Sub
list array in other sheet
code details
Sub Filter()
Dim Criteria As Variant
Criteria = Worksheets("Sheet1").Range("A1:A140")
Worksheets("AP").Range("$A$1:$h$100").AutoFilter Field:=3, Criteria1:=Criteria, Operator:=xlFilterValues
End Sub
it is filtering only the first value and not all values in the column
(it should filter all values contains)
Problem:
You are defining your array from a Range, that gives you a 2D array, which you cannot pass into Autofilter Easily. So we have to change it into 1D Array.
Solution: Change your second code to this:
Sub Filter()
Dim Criteria As Variant
Dim cri() As String
Criteria = Worksheets("Sheet1").Range("A1:A140")
ReDim Preserve cri(UBound(Criteria))
For I = LBound(Criteria) To UBound(Criteria)
cri(I) = Criteria(I, 1)
Next
Worksheets("AP").Range("$A$1:$h$100").AutoFilter Field:=1, Criteria1:=cri, Operator:=xlFilterValues
End Sub
Alternative: The code that you are using is Fixed Code. There is one Dynamic code that could be also of use for you. Check this Answer.
I'm very new to VBA and was hoping to get come clarification on a project. I've tried solving it with formulas but I need to still be able to enter information into cells and not have them filled with a lookup formula.
How I'm looking for it to preform is that if an object requires it to be shipped then the serial numbers and identifiers are copied and pasted in another table in the next blank row automatically.
Information divided into two tables
What I thought I needed was a segment in VBA that went like this:
Sub CopyCat()
If Range("J2") Like "*yes*" then
Range("G2:I2").copy
Range("A2:A10").end(xlup).offset(1).pasteSpecial xlpastevalues
If Range("J3") Like "*yes*" then
Range("G3:I3").copy
Range("A2:A10").end(xlup).offset(1).pasteSpecial xlpastevalues
End If
End If
End Sub
It does exactly what I ask it to do when it is only the first statement, when I add the second one to check if the next row satisfies the conditions and it does, then it places it in the same resulting cell as the first statement. If both are true I need them both to be displayed in table 1.
I'd love to take this as a learning opportunity so any information or direction you can point me in would be great! Thank you so much in advance!
I think Range("A2:A10").end(xlup) is equivalent to Range("A2").end(xlup) so will not change, but you don't want the A2 reference, you want to work up from the bottom. You will hit problems if you are going beyond A9. (Plus not sure you want nested Ifs.)
If Range("J2") Like "*yes*" Then
Range("G2:I2").Copy
Range("A10").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
If Range("J3") Like "*yes*" Then
Range("G3:I3").Copy
Range("A10").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Or to add a loop and circumvent the copy/paste you could use something like this:
Sub CopyCat()
Dim r As Long
For r = 2 To Range("J" & Rows.Count).End(xlUp).Row
If Range("J" & r) Like "*yes*" Then
Range("A10").End(xlUp).Offset(1).Resize(, 3).Value = Range("G" & r).Resize(, 3).Value
End If
Next r
End Sub
You can also do this without VBA.
In A2, you can use this formula entered as an array formula with CTRL+SHIFT+ENTER:
=INDEX($G$2:$G$4,SMALL(IF($J$2:$J$4="yes",ROW($J$2:$J$4)-ROW($J$2)+1),ROWS(J$2:J2)))
And in B2, you can put this and drag down/over from B2:D3:
=INDEX(H$2:H$4,MATCH($A2,$G$2:$G$4,0))
Finally, to hide the errors that show when there are no more matches, you can simply wrap both above formulas in IFERROR([formula above],"").
With autofilter
Sub copyRange()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim lastRow As Long
Dim filterRange As Range
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet2") 'change to sheet name containing delivery info
With wsSource
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
Set filterRange = .Range("G1:K" & lastRow)
Dim copyRange As Range
Set copyRange = .Range("G2:K" & lastRow)
End With
Dim lastRowTarget As Long, nextTargetRow As Long
With filterRange
.AutoFilter
.AutoFilter Field:=4, Criteria1:="yes" 'change field to whichever is the field in the range containing your company names
lastRowTarget = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
nextRowTarget = lastRowTarget + 1
Union(wsSource.Range("G2:I" & lastRow).SpecialCells(xlCellTypeVisible), wsSource.Range("K2:K" & lastRow).SpecialCells(xlCellTypeVisible)).Copy wsSource.Range("A" & nextRowTarget)
.AutoFilter
End With
End Sub
I have a code that finds the last row of data in column E and selects the column to that last row. I want to be able to select associated data in columns B through D that goes with column E and then sort based on column B. So I thought I would just find the last row in column E then resize by 3 columns and sort from that selection but I keep getting a run-time error 1004 application-defined or object-defined error. I have provided the code I'm using below. Columns B through D contain data past the end of column E. Thanks!
ws.Range("E1:E" & finalrow).Resize(0, 3).Select
You may not always be starting in the first row (e.g. E1) so lastRow may not be applicable without some maths. In that case, use With ... End With statements to shorten the code while explicitly referencing the correct cell and cell ranges.
dim lastRow as long
with ws
lastRow = .cells(.rows.count, "E").end(xlup).row
'option 1
.range("B5:D" & lastRow).select
'option 2
with .range("E5:E" & lastRow)
.offset(0, -3).resize(.rows.count, 3).select
end with
'option 3
.range("E5", .cells(lastRow, "G")).offset(0, -3).select
end with
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on Range.Select and Range.Activate to accomplish your goals.
Something like:
Sub SelectLast3Cols()
Dim ws As Worksheet, lrow As Long
Set ws = Sheets("Sheet3")
lrow = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
ws.Range("B1", ws.Range("D" & lrow)).Select
End Sub
I have a big database-like sheet, first row contains headers. I would like a subset of rows of this table based on column values. Two issues:
1) VBA-wise I would like to loop through the columns, when the values for all necessary columns all match, copy the entire row into a new sheet.
2) The subset of rows is based on a list. I just read I can use Autofilter with an array. Is it possible to input this array from a column instead of manually entering it in the VBA code? The list I'm using consists of 200 different strings and will be updated periodically.
Where CritList is the list of strings. I still need to figure out how, but now I leave the office, so more tomorrow.
EDIT1 Thanks to #DougGlancy; the autofiltering works now. Here is his beautiful code (I only added the array-filter).
EDIT2 Included a more elaborate array-filter, where NameList is the list I would like to filter for. Now it all works!
Sub FilterAndCopy()
Dim LastRow As Long
Dim vName As Variant
Dim rngName As Range
Set rngName = Sheets("Sheet3").Range("NameList")
vName = rngName.Value
Sheets("Sheet2").UsedRange.Offset(0).ClearContents
With Worksheets("Sheet1")
.Range("A:E").AutoFilter
'Array filter from NameList
.Range("A:J").AutoFilter Field:=3, Criteria1:=Application.Transpose(vName), _
Operator:=xlFilterValues
.Range("A:E").AutoFilter field:=2, Criteria1:="=String1" _
, Operator:=xlOr, Criteria2:="=string2"
.Range("A:E").AutoFilter field:=3, Criteria1:=">0", _
.Range("A:E").AutoFilter field:=5, Criteria1:="Number"
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Destination:=Sheets("Sheet2").Range("A1")
End With
End Sub
Here's a different approach. The heart of it was created by turning on the Macro Recorder and filtering the columns per your specifications. Then there's a bit of code to copy the results. It will run faster than looping through each row and column:
Sub FilterAndCopy()
Dim LastRow As Long
Sheets("Sheet2").UsedRange.Offset(0).ClearContents
With Worksheets("Sheet1")
.Range("$A:$E").AutoFilter
.Range("$A:$E").AutoFilter field:=1, Criteria1:="#N/A"
.Range("$A:$E").AutoFilter field:=2, Criteria1:="=String1", Operator:=xlOr, Criteria2:="=string2"
.Range("$A:$E").AutoFilter field:=3, Criteria1:=">0"
.Range("$A:$E").AutoFilter field:=5, Criteria1:="Number"
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Destination:=Sheets("Sheet2").Range("A1")
End With
End Sub
As a side note, your code has more loops and counter variables than necessary. You wouldn't need to loop through the columns, just through the rows. You'd then check the various cells of interest in that row, much like you did.