Filters

J

JAvila2k

New Member
Joined
Aug 27, 2017
Messages
8
Hi All,
I have access this forum multiple times as a guest and I have found many answers to my issues; however, I have now one problem that I cannot figure out a solution. I would like to ask for your help since I am not a VBA guru and I am new in the forum.

Here is my issue:
I have one sheet (Sheet1) with following sample values (real sheet has more values)
Column1
Column2
Column3
Column4
Column5
Column6
Column7
Value1
10
Value2
20
Value3
30
Value4
45
Value5
65
Value6
88
Value7
90

<tbody>
</tbody>

I also have a second sheet with following values:
Column1
Column2
Column3
Column4
Column5
Column6
Column7
10
1
10
3
10
5
20
10
20
15
20
16
30
20
30
21
30
22

<tbody>
</tbody>

My goal is to create a macro that will read the first value (i.e. 10) from Sheet1 column 7 and use it as filter for the values in sheet2 (column 2 as Key). Once the rows are filtered (i.e. 3 rows with value 10); copy these in memory and switch back to sheet 1> add a row underneath original number (10)and 'insert copy cells' .
This following table shows my intended goal.

Column1
Column2
Column3
Column4
Column5
Column6
Column7
Value1
10
10
1
10
3
10
5
Value2
20
20
10
20
15
20
16
Value3
30
30
20
30
21
30
22
Value7
90

<tbody>
</tbody>
So far, I have a macro that works for the first value (Sheet 1 - G2 cell as active) but when I select the second value in sheet1 column 7 (i.e. 20). The macro does not work anymore:

Following is my code so far:

NOTE: I'm open to any other approach if your gurus feel is better.
Also, the real files will have more rows in them.

Sorry for above tables but once I figure out how to paste images or add files I will do it.

Thanks in advance,



Sub CopyFilteredValues()
Dim CLValue As String
Dim cellAddress2 As Integer
CLValue = ActiveCell.Value
cellAddress = ActiveCell.Address
Sheets("Sheet2").Select

Set My_Range = Range("$A$2:$G$10")
My_Range.Parent.Select
My_Range.Parent.AutoFilterMode = False

My_Range.AutoFilter Field:=2, Criteria1:=CLValue
My_Range.Parent.AutoFilter.Range.Copy

Sheets("Sheet1").Select


ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
End Sub
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
Re: Help needed with Filters (New Member)

Try:
Code: 
Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow1 As Long
    LastRow1 = Sheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    Dim LastRow2 As Long
    LastRow2 = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    Dim x As Long
    Dim y As Long
    y = Sheets("Sheet1").Range("G2:G" & LastRow1).Cells.Count
    On Error Resume Next
    For x = 2 To y * 4 Step 4
        If Not Sheets("Sheet2").Range("B:B").Find(Sheets("Sheet1").Cells(x, "G"), LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
            Sheets("Sheet2").Select
            Range("B1").Select
            Selection.AutoFilter
            Range("A1" & ":G" & LastRow2).AutoFilter Field:=2, Criteria1:=Cells(x, "B")
            Range("A2" & ":G" & LastRow2).SpecialCells(xlCellTypeVisible).Copy
            Sheets("Sheet1").Range("A" & x + 1).Rows("1:1").Insert Shift:=xlDown
            If Sheets("Sheet2").FilterMode Then Sheets("Sheet2").ShowAllData
        Else
            Exit Sub
        End If
    Next x
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Re: Help needed with Filters (New Member)

Hi Mumps,

Thank you so much for your answer; it really does what I need it.

I know that most of the times there is more than one way to do things; however, some of them are more 'elegant' that other ones (just like this one).

I will start running with all my files and I will make some additional changes.

Thanks again!
 
Upvote 0
Re: Help needed with Filters (New Member)

Hi Mumps,

I have ran into some issues because some of the set of values in Sheet2 won't have the same number of entries; in these cases the 'Step 4' in the For loop won't always work.

See below table with some additional sample rows.

Any ideas how to handle it?

Thanks,

Column1
Column2
Column3
Column4
Column5
Column6
Column7
10
1
10
3
10
5
20
10
20
15
20
16
30
20
30
21
30
22
45
20
65
21
65
22
65
23
65
30
88
40
88
60
90
61
90
62

<tbody>
</tbody>
 
Upvote 0
Re: Help needed with Filters (New Member)

Try this macro.
Code: 
Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow1 As Long
    LastRow1 = Sheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    Dim LastRow2 As Long
    LastRow2 = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    Dim x As Long
    Dim z As Long
    Dim a As Long
    a = 0
    On Error Resume Next
    For x = 2 To 100
        If Not Sheets("Sheet2").Range("B:B").Find(Sheets("Sheet1").Cells(x, "G"), LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
            Sheets("Sheet2").Select
            Range("B1").Select
            Selection.AutoFilter
            Range("A1" & ":G" & LastRow2).AutoFilter Field:=2, Criteria1:=Sheets("Sheet1").Cells(x - a, "G")
            Range("A2" & ":G" & LastRow2).SpecialCells(xlCellTypeVisible).Copy
            z = ActiveSheet.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count - 1
            If Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row > 1 Then
                Sheets("Sheet1").Range("A" & Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + 2).Rows("1:1").Insert Shift:=xlDown
            ElseIf Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row = 1 Then
                Sheets("Sheet1").Range("A3").Rows("1:1").Insert Shift:=xlDown
            End If
            x = x + z + 1
            a = a + 1
            If Sheets("Sheet2").FilterMode Then Sheets("Sheet2").ShowAllData
        Else
            Exit Sub
        End If
    Next x
    Application.ScreenUpdating = True
End Sub
The only stipulation is that you have to change the "100" in this line of code
Code: 
For x = 2 To 100
to a number that is maybe 25 greater than the number of rows of data that you will have in Sheet1 after the macro has run. For example, using the data from your previous post, you will have 26 rows of data in Sheet1 so a number like 30 would work. If you run the macro and find that you have missing data at the bottom, increase the number. There may be a more efficient way to do this but I couldn't come up with one.
 
Upvote 0
Re: Help needed with Filters (New Member)

Mumps,

I found out that some of the values in Sheet1 might not exist in Sheet2 and in this case the macro needs to skip to next number; I did a couple of changes and I can get to the next number in the list but I cannot get to insert the values in the right row (you could test just removing the values for 65 in Sheet2).
Here is the For loop with a couple changes.
If Not Sheets("Sheet2").Range("B:B").Find(Sheets("Sheet1").Cells(x - a, "G"), LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
Sheets("Sheet2").Select
Range("B1").Select
Selection.AutoFilter
Range("A1" & ":G" & LastRow2).AutoFilter Field:=2, Criteria1:=Sheets("Sheet1").Cells(x - a, "G")
Range("A2" & ":G" & LastRow2).SpecialCells(xlCellTypeVisible).Copy
z = ActiveSheet.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row > 1 Then
Sheets("Sheet1").Range("A" & Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + 2).Rows("1:1").Insert Shift:=xlDown
ElseIf Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row = 1 Then
Sheets("Sheet1").Range("A3").Rows("1:1").Insert Shift:=xlDown
End If
x = x + z + 1
a = a + 1
If Sheets("Sheet2").FilterMode Then Sheets("Sheet2").ShowAllData
Else
x = x + 1
a = a + 1
'Exit Sub
End If

Any ideas?

Thanks in advance,
 
Upvote 0
Re: Help needed with Filters (New Member)

Try this one:
Code: 
Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow1 As Long
    LastRow1 = Sheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    Dim LastRow2 As Long
    LastRow2 = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    Dim x As Long
    Dim z As Long
    Dim a As Long
    a = 0
    Dim b As Long
    b = 2
    On Error Resume Next
    For x = 2 To 100
        If Not Sheets("Sheet2").Range("B:B").Find(Sheets("Sheet1").Cells(x - a, "G"), LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
            Sheets("Sheet2").Select
            Range("B1").Select
            Selection.AutoFilter
            Range("A1" & ":G" & LastRow2).AutoFilter Field:=2, Criteria1:=Sheets("Sheet1").Cells(x - a, "G")
            Range("A2" & ":G" & LastRow2).SpecialCells(xlCellTypeVisible).Copy
            z = ActiveSheet.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count - 1
            If z > 0 Then
                If Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row > 1 Then
                    Sheets("Sheet1").Range("A" & Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + b).Rows("1:1").Insert Shift:=xlDown
                ElseIf Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row = 1 Then
                    Sheets("Sheet1").Range("A3").Rows("1:1").Insert Shift:=xlDown
                End If
                x = x + z + 1
                a = a + 1
            End If
            If Sheets("Sheet2").FilterMode Then Sheets("Sheet2").ShowAllData
            b = 2
        Else
            b = 3
        End If
    Next x
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Re: Help needed with Filters (New Member)

Mumps,

First of all thank you so much for your help; I have learn just analyzing your code.

I ran the code in a few test cases and it did work really well.

However, I started running on larger datasets and the problem I have now is that is some cases there might be two (or more) consecutives values from Sheet1 that have no values within Sheet2. In this cases the code is not working as expected.

Do you know these cases can be handle as well?

Thanks,
 
Upvote 0
Re: Help needed with Filters (New Member)

Give this a try:
Code: 
Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow1 As Long
    LastRow1 = Sheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    Dim LastRow2 As Long
    LastRow2 = Sheets("Sheet2").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    Dim x As Long
    Dim z As Long
    Dim a As Long
    a = 0
    Dim b As Long
    b = 2
    On Error Resume Next
    For x = 2 To 100
        If Not Sheets("Sheet2").Range("B:B").Find(Sheets("Sheet1").Cells(x - a, "G"), LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
            Sheets("Sheet2").Select
            Range("B1").Select
            Selection.AutoFilter
            Range("A1" & ":G" & LastRow2).AutoFilter Field:=2, Criteria1:=Sheets("Sheet1").Cells(x - a, "G")
            Range("A2" & ":G" & LastRow2).SpecialCells(xlCellTypeVisible).Copy
            z = ActiveSheet.AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count - 1
            If z > 0 Then
                If Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row > 1 Then
                    Sheets("Sheet1").Range("A" & Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + b).Rows("1:1").Insert Shift:=xlDown
                ElseIf Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row = 1 Then
                    Sheets("Sheet1").Range("A3").Rows("1:1").Insert Shift:=xlDown
                End If
                x = x + z + 1
                a = a + 1
            End If
            If Sheets("Sheet2").FilterMode Then Sheets("Sheet2").ShowAllData
            b = 2
        Else
            b = b + 1
        End If
    Next x
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
dynamic data changes
Replies
0
Views
122
DSCHROE67
D
V
  • Question
Lookup heirarchy Value in Multiple Columns and Return Value from Column
Replies
7
Views
300
Special-K99
S
Q
  • Question
How do I pass a string variable to the web.contents argument of Power Query (Get & Transform)?
Replies
3
Views
647
Mario_R
M
T
  • Solved
LOOKUP and SEARCH functions to return a value within a string and accounting for blanks
Replies
9
Views
359
Fluff
Fluff
L
  • Question
Importing from pdf to excel workbook using VBA and PowerQuery
Replies
1
Views
2K
John_w
J

Forum statistics

Threads
1,215,410
Messages
6,124,749
Members
449,186
Latest member
HBryant

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top