Filter Column and copy the other values in same row but other columns to new worksheet

[miss_anonymous]

Good evening guys,

Unfortunatelly my (huge) reference book for excel is not able to answer my current makro question:

In my worksheet "data" is my data collection.
There I want to filter Column B (containing all eyecolors) for only "green" and copy the other values within the same row in Column D (age) and Column F (gender) to a new worksheet.

new worksheet side by side:
eyecolor_____age__________gender__
green 7 female
green 8 male
green 9 female

I'm not sure how to create the indirect cell reference for EXCEL 2003.

Sorry for bothering you, but my little makro skills reach theirs here.

It would be great hearing of you!

Miss_Anonymous

 

[Glory]

Something similar to this might work but there's lots of better ways.

Public Sub Test1()
 
Set theRange = Intersect(ThisWorkbook.Sheets("Data").Range("B:B"), ThisWorkbook.Sheets("Data").UsedRange)
 
If theRange Is Nothing Then: MsgBox "No data in column B": Exit Sub: End If
 
For Each Cell in theRange
 
    If Cell = "Green" Then 
        a = a + 1
        If a = 1 then set b = ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets("Data")
 
        With b
 
            .Name = "Filtered Data from " & TimeValue(Now)
            .Range("a1") = "Eyecolor" 
            .Range("a2") = "Age"
            .Range("a3") = "Gender"
 
 
        End If
 
            .Range("a1").Offset(a,0) = Cell
            .Range("b1").Offset(a,0) = Cell.Offset(,2)
            .Range("c1").Offset(a,0) = Cell.Offset(,3)
 
        End With
 
Next
 
End Sub

 

[miss_anonymous]

Thank you very much for your great input.

I'm afraid, but the error message is "synthax error"

concerning this line:

If a = 1 then set b = ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets("Data")

Can anyone help me?

the Code so far:

Public Sub Test2()

Dim a As Integer

Set theRange = Intersect(ThisWorkbook.Sheets("Data").Range("C4:C13"), ThisWorkbook.Sheets("Data").UsedRange)


For Each Cell In theRange

If Cell = "brown" Then
a = a + 1
If a = 1 then set b = ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets("Data")

With b

.Name = "Filtered Data from " & TimeValue(Now)
.Range("a1") = "Eyecolor"
.Range("a2") = "Age"
.Range("a3") = "Gender"




.Range("a1").Offset(a, 0) = Cell
.Range("b1").Offset(a, 0) = Cell.Offset(, 2)
.Range("c1").Offset(a, 0) = Cell.Offset(, 3)

End With
End If
Next
End Sub