Extract data based on table of conditions

[YasserKhalil]

Hello everyone
I have data in sheet1 in range("B3:C14") in two columns one for code and the other for date

Based on the table in range("F1:I2") I need to extract data to another sheet ..based on the code number in F2 & G2 in the period between the two dates in H2 & I2
There is the expected output to illustrate my need and if possible to format the output ..
Thanks advanced

[FDibbins]

I did this with a very simple Pivot Table...

	J	K	L
4		Row Labels
5		1
6		1-Jan
7		2-Jan
8		4-Jan
9		2
10		2-Jan
11		3-Jan
12		6-Jan
13		3
14		5-Jan
15		6-Jan
16		Grand Total
17

Use both Code and then Date as row labels

[YasserKhalil]

Thanks a lot for reply
But I need the output to be between two dates..
In fact I prefer coding as I need the output to be formatted like attached

[Obsessed]

Try this...sorry, took longer than I thought:

Sub CreateTable()

Dim LR As Long, R As Long, DR As Long
Dim N As Byte
Dim sDate As Single, eDate As Single
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
sDate = ws1.Range("H2")
eDate = ws1.Range("I2")
DR = 1

LR = ws1.Range("B" & ws1.UsedRange.Rows.Count + 2).End(xlUp).Row

If LR = 3 Then
    MsgBox ("No Data!")
    Exit Sub
End If

For N = ws1.Range("F2").Value To ws1.Range("G2").Value
    DR = DR + 1
    With ws2.Range("B" & DR)
        .Value = N
        .Interior.ColorIndex = 27
    End With
    DR = DR + 1
    With ws2.Range("B" & DR & ":C" & DR)
        .Value = Array("Code", "Date")
        .Interior.ColorIndex = 20
    End With
    DR = DR + 1
    For R = 4 To LR
        If ws1.Cells(R, 2).Value = N And eDate >= ws1.Cells(R, 3).Value And ws1.Cells(R, 3).Value >= sDate Then
            ws2.Cells(DR, 2).Value = ws1.Cells(R, 2).Value
            ws2.Cells(DR, 3).Value = ws1.Cells(R, 3).Value
            DR = DR + 1
        End If
    Next R
Next N

With ws2.Range("B2:C" & DR - 1)
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With .Borders(xlEdgeBottom)
        .Weight = xlThin
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
        .HorizontalAlignment = xlCenter
End With
ws2.Range("C2:C" & DR - 1).NumberFormat = "d-mmm"

End Sub

[karedog]

Maybe :

Sub Test()
  Dim coll As New Collection, collDummy As New Collection
  Dim rngHeader1 As Range, rngHeader2 As Range, arrCri, arrTmp, i As Long, tot As Long, str1 As String, v1, v2
  With Sheet1
    arrCri = .Range("F2:I2").Value
    arrTmp = .Range("B3").CurrentRegion.Value
  End With

  On Error Resume Next
  For i = 2 To UBound(arrTmp, 1)
      If (arrTmp(i, 1) >= arrCri(1, 1)) And (arrTmp(i, 1) <= arrCri(1, 2)) And (arrTmp(i, 2) >= arrCri(1, 3)) And (arrTmp(i, 2) <= arrCri(1, 4)) Then
         Set collDummy = Nothing
         tot = tot + 1
         str1 = CStr(arrTmp(i, 1))
         coll.Add key:=str1, Item:=Array(str1, collDummy)
         coll(str1)(1).Add arrTmp(i, 2)
     End If
  Next i
  On Error GoTo 0
  ReDim arrTemp(1 To (tot + (coll.Count * 3)), 1 To 2)

  With Sheets("Expected Output")
    .Cells.Clear
    i = 0: Set rngHeader1 = .Rows(1): Set rngHeader2 = .Rows(1)
    For Each v1 In coll
        arrTemp(i + 2, 1) = v1(0): Set rngHeader1 = Union(rngHeader1, Rows(i + 2))
        arrTemp(i + 3, 1) = "Code": Set rngHeader2 = Union(rngHeader2, Rows(i + 3))
        arrTemp(i + 3, 2) = "Date"
        i = i + 3
        For Each v2 In v1(1)
            i = i + 1
            arrTemp(i, 1) = v1(0)
            arrTemp(i, 2) = v2
        Next v2
    Next v1
    With .Range("B1").Resize(UBound(arrTemp, 1), UBound(arrTemp, 2))
      .Value = arrTemp
      .Borders.Weight = xlThin
      Intersect(.Resize(, 1), rngHeader1).Interior.Color = 65535
      Intersect(.Resize(, 2), rngHeader2).Interior.Color = 13434879
      .Columns(2).NumberFormat = "DD-MMM"
      .HorizontalAlignment = xlCenter
      .EntireColumn.AutoFit
    End With
    .Rows(1).Clear
  End With
End Sub

[YasserKhalil]

Thanks a lot Mr. Obsessed for this helpful solution..It's great
Mr. Karedog
I tested the code and I got an error (Method 'Union' of object'_Global failed) at this line

Set rngHeader1 = Union(rngHeader1, Rows(i + 2))

Thanks a lot for offering help

[karedog]

Sorry, forget the dot :

        'arrTemp(i + 2, 1) = v1(0): Set rngHeader1 = Union(rngHeader1, Rows(i + 2))
        'arrTemp(i + 3, 1) = "Code": Set rngHeader2 = Union(rngHeader2, Rows(i + 3))
        arrTemp(i + 2, 1) = v1(0): Set rngHeader1 = Union(rngHeader1, .Rows(i + 2))
        arrTemp(i + 3, 1) = "Code": Set rngHeader2 = Union(rngHeader2, .Rows(i + 3))

[YasserKhalil]

Never mind at all Mr. Karedog
It's my fault not yours .. I have to correct this simple error on my own
Now It is VERY PERFECT
Thank you very very much

Many thanks too to Mr. Obsessed for his great solution

[karedog]

You are welcome, it is my fault not yours


Regards