Filters

[JAvila2k]

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

---

 

[JAvila2k]

Re: Help needed with Filters (New Member)

Mumps,

I have now run a few set of files; some of them with around 10000-15000 thousand lines and code it's working great.

I will start looking into the code logic to understand it better. Also, I might contact you in the near future because a new need has came up (we might need a third level). I will give it a try and let you know if I run into problems.

Once again, THANK YOU so much for all your help.

Regards,

 

[mumps]

Re: Help needed with Filters (New Member)

You are very welcome.

 

[JAvila2k]

Hi Mumps,

I have started working on the three levels macro; also I have looked into detailed to the code and I have a couple of questions, I hope you can help me before I try to go any further.

Could you please explained the use of the 'a' counter? I was able to get rid of it by changing the x counter from:
x = x + z + 1
to
x = x +z

This way we can have the total number of rows (1 and 2) to be used for the 'x For loop'. - Just adding the two of them.

Also, I make a few change to handle if the initial rows from Sheet1 do not exist in Sheet2.

As I mentioned; could you please explain the meaning of the a counter? I just want to make sure I don't oversee something.

Thanks,


Here is the code after a couple of changes.

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
    totalRows1and2 = LastRow1 + LastRow2 + 100
    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 totalRows1and2 '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, "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("A" & b + 1).Rows("1:1").Insert Shift:=xlDown
                End If
                'x = x + z + 1
                'a = a + 1
                x = x + z
            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

 

[mumps]

I've tried your code and it works properly. Your changes have made it more efficient and so the "a" appears to be no longer necessary. Give it a try with your three levels and see how it works out.