Using If function to separate data into multiple sheet

[offthelip]

Try this, Note I haven't tested this, or even tried to compile it, so there may well be errors

Private Sub Worksheet_Activate()
Dim WS_Count As Integer
Dim I AsInteger
Dim rowcounterA() As Integer
Dim rowcounterD() As Integer
With Worksheets("Menu")
LastrowA = .Cells(Cells.Rows.Count, "A").End(xlUp).Row
LastrowD = .Cells(Cells.Rows.Count, "D").End(xlUp).Row
if LastrowA > lastrowD
inarr = .Range(.Cells(1, 1), .Cells(LastrowA, 4))
else
inarr = .Range(.Cells(1, 1), .Cells(LastrowD, 4))
endif
EndWith
WS_Count = ActiveWorkbook.Worksheets.Count
ReDim rowcounterA(1 To WS_Count)
ReDim rowcounterD(1 To WS_Count)
For I = 1 To WS_Count
rowcounterA(I) = 0
rowcounterD(I) = 0
With Worksheets(I)
If Not (.Name = "Menu") Then
For j = 3 To LastrowA
If inarr(j, 1) = .Cells(1, 2) Then
.Cells(216 + rowcounterA(I), 11) = inarr(j, 3)
rowcounterA(I) = rowcounterA(I) + 1
endif
nextj
For j = 3 To LastrowD
If inarr(j, 4) = .Cells(1, 2) Then
.Cells(216 + rowcounterD(I), 12) = inarr(j, 3)
rowcounterD(I) = rowcounterD(I) + 1
End If
Next j
End If
End With
Next I
End Sub