Oct 20 2020 01:40 AM
Hi,
I'm currently trying to find a VBA code that will allow me to do the below:
- Filter Column A in sheet 1
- If the filter returns data then copy this data over to a specific sheet (i.e. sheet 2). But only columns C-I with no headers
- If there is no data in this report that matches the filter then simply move onto the next filter.
Can anyone help me with this?
Thanks in advance!
Oct 20 2020 03:36 AM
@RAM98988 wrote:Hi,
I'm currently trying to find a VBA code that will allow me to do the below:
- Filter Column A in sheet 1
Filter what?
- If the filter returns data then copy this data over to a specific sheet (i.e. sheet 2). But only columns C-I with no headers
- If there is no data in this report that matches the filter then simply move onto the next filter.
Which next Filter?
Can anyone help me with this?
Yes, we can help if you upload a sample file and explain the steps again considering the data in the sample file. And if required, mock up the desired output manually on Sheet 2.
Oct 20 2020 04:05 AM
Hi attached is a file similar to the one I am working with.
My aim is for the VBA to filter in 'Sheet 1' column A for 1
If there is corresponding data copy and paste from C-I (excluding headers) in sheet '1'
If not do not copy anything over.
Then filter column A for 2
If there is corresponding data copy and paste from C-I (excluding headers) in sheet '2'
If not do not copy anything over.
And so on.
Hopefully this makes more sense.
Thanks!
Oct 20 2020 05:52 AM
SolutionPlease give this a try and let me know if you get the desired output.
Sub FilterAndCopy()
Dim wsData As Worksheet
Dim dws As Worksheet
Dim lr As Long
Dim x As Variant
Dim dict As Object
Dim it As Variant
Dim i As Long
Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet1")
lr = wsData.Cells(Rows.Count, "A").End(xlUp).Row
x = wsData.Range("A2:A" & lr).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For Each it In dict.keys
On Error Resume Next
Set dws = Worksheets(CStr(it))
dws.Cells.Clear
On Error GoTo 0
If dws Is Nothing Then
Set dws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
dws.Name = it
End If
With wsData.Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:=it
wsData.Range("C2:I" & lr).SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
.AutoFilter
End With
Set dws = Nothing
Next it
Application.ScreenUpdating = True
End Sub
Please click the button called "Filter And Copy" on Sheet1 in the attached to run the code.
Oct 20 2020 06:28 AM
Yes thats great thanks. I do have one other query:
If there was already data in the sheets the data is being copied into, is there a way to paste it below that data?
Thanks so much!
Oct 20 2020 08:30 AM
Okay, please give this a try.
And if that takes care of your original question, please take a minute to accept the post with the provided solution as a Best Response to mark your question as Solved.
Sub FilterAndCopy()
Dim wsData As Worksheet
Dim dws As Worksheet
Dim lr As Long
Dim x As Variant
Dim dict As Object
Dim it As Variant
Dim i As Long
Dim dlr As Long
Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet1")
lr = wsData.Cells(Rows.Count, "A").End(xlUp).Row
wsData.AutoFilterMode = False
x = wsData.Range("A2:A" & lr).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For Each it In dict.keys
On Error Resume Next
Set dws = Worksheets(CStr(it))
On Error GoTo 0
If dws Is Nothing Then
Set dws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
dws.Name = it
End If
With wsData.Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:=it
dlr = dws.Cells(Rows.Count, "A").End(xlUp).Row
If dws.Range("A1").Value <> "" Then dlr = dlr + 1
wsData.Range("C2:I" & lr).SpecialCells(xlCellTypeVisible).Copy dws.Range("A" & dlr)
.AutoFilter
End With
Set dws = Nothing
Next it
Application.ScreenUpdating = True
End Sub
Oct 21 2020 02:39 AM - edited Oct 21 2020 04:23 AM
Perfect thank you, out of interest and for potential future reference is it possible to use offsets within this code in order to move the paste range up/down/left/right?
Thanks.
Oct 21 2020 03:30 AM
You're welcome!
Yes, you just need to change the destination range dws.Range("A" & dlr) in the following line as per your requirement.
wsData.Range("C2:I" & lr).SpecialCells(xlCellTypeVisible).Copy dws.Range("A" & dlr)
Jun 22 2021 03:17 AM
I know this is an old post, but how can I change the column which is being filtered (to column B for example)?
I've tried simply changing:
x = wsData.Range("A2:A" & lr).Value
to
x = wsData.Range("B2:B" & lr).Value
But I get a run-time error '1004' "No Cells Were Found".
Any suggestions are much appreciated, this is my first time using VBA so I'm a complete beginner!
Jun 23 2021 07:53 AM
Jan 28 2022 09:46 AM
First of all, thank you very much for the code, @Subodh_Tiwari_sktneer ! It's been super helpful.
@Fliptoe -- I know your question is 6 months old, but here's a potential explanation to the filtering issue. In line 35 of the latest version of Subodh's code:
.AutoFilter field:=1, Criteria1:=it
The field # represents the column it is filtering -- in this case, 1 = column "A"; 2 = column "B"; and so on.
This line works in tandem with code lines 14-18, where you're setting the range of terms for the scripting dictionary. So, if you'd like to filter by column "B", then change the letter "A" to "B" in code lines 14 & 18, and change line 35 to "field:=2".
Hope that helps!
Apr 04 2022 12:33 AM
Oct 20 2020 05:52 AM
SolutionPlease give this a try and let me know if you get the desired output.
Sub FilterAndCopy()
Dim wsData As Worksheet
Dim dws As Worksheet
Dim lr As Long
Dim x As Variant
Dim dict As Object
Dim it As Variant
Dim i As Long
Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet1")
lr = wsData.Cells(Rows.Count, "A").End(xlUp).Row
x = wsData.Range("A2:A" & lr).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For Each it In dict.keys
On Error Resume Next
Set dws = Worksheets(CStr(it))
dws.Cells.Clear
On Error GoTo 0
If dws Is Nothing Then
Set dws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
dws.Name = it
End If
With wsData.Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:=it
wsData.Range("C2:I" & lr).SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
.AutoFilter
End With
Set dws = Nothing
Next it
Application.ScreenUpdating = True
End Sub
Please click the button called "Filter And Copy" on Sheet1 in the attached to run the code.