Copy 2 cells from each Row (into another Workbook) Based on Criteria of a third cell?

Anyone able to make it do the first 3 points? I could figure out the rest after that.

A bit confusing.

Can you post a workbook that should be generated?

Sorry, I realise my explanation isn't very good . I've attached what I want it to generate (or something which is as close to this visually as possible) and exampledispatchsheet .xls has a total of 6 sheets, which are all the customers to dispatch to on 25/10/13. First sheet is full list, sorted by Branch number, and next 5 are them split into separate branches.

So It should take user input for the date, and then where I've put 25/10/13, it should put my Inputted date. Hope this is a bit clearer, need any clarification please let me know.

Let's see if this is what you wanted.

Amazing! Thanks a lot jindon. Might make a few mods, but will post my final example tomorrow so everyone can see. Thanks again!

Nitpicking here, but is there a way to stop the outputted excel file from squashing the names of the customers? The Date comes up fine, but just seems to be the names where the cell is too small and also in here

                    .Range("d2").Value = myDate
                    .Range("a3").Value = "Name:"
                    .Range("e3").Value = "Delivery No:"

How to also put those cells in bold?

Can you show me EXACTLY how you want in a workbook?

Sorry, trying to make it like this. Just if Name and Delivery No is in bold, and also, if the sheet is made so that it autofits the cells in Column B for the patient names? So they don't get squashed
And also, on this example, on Sheet 1 it places the list so that it tries to fit on one page as much as possible.

Try change to

Option Explicit

Sub test()
    Dim dic As Object, myDate, a, i As Long, e, flg As Boolean, x As Range, t As Long
    Dim r As Range
    Set r = Application.InputBox("Select cell that has the date to pick", Type:=8)
    If Not IsDate(r.Value) Then
        MsgBox "Invalid entry": Exit Sub
    End If
    myDate = r.Value
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1").Range("a3").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            For Each e In Array(4, 7, 10)
                If a(i, e) = myDate Then
                    flg = True: Exit For
                End If
            Next
            If flg Then
                If x Is Nothing Then Set x = .Rows(1).Columns("a:b")
                If Not dic.exists(a(i, 1)) Then
                    Set dic(a(i, 1)) = .Rows(1).Columns("a:b")
                End If
                Set dic(a(i, 1)) = Union(dic(a(i, 1)), .Rows(i).Columns("a:b"))
                Set x = Union(x, .Rows(i).Columns("a:b")): flg = False
            End If
        Next
    End With
    If Not x Is Nothing Then
        With Workbooks.Add
            x.Copy .Sheets(1).Range("a3")
            With .Sheets(1)
                .Range("c1").Value = myDate
                .Range("c1").Font.Bold = True
                With .Range("a3").CurrentRegion
                    If .Rows.Count > 47 Then
                        For i = 48 To .Rows.Count Step 47
                            t = t + 3
                            .Rows(i).Resize(46).Cut .Cells(1, t)
                        Next
                    End If
                End With
                .Columns.AutoFit
            End With
            For i = 0 To dic.Count - 1
                If .Sheets.Count < i + 2 Then
                    .Sheets.Add after:=.Sheets(.Sheets.Count)
                End If
                With .Sheets(i + 2)
                    dic.items()(i).Copy .Range("a5")
                    .Range("d2").Value = myDate
                    .Range("a3").Value = "Name:"
                    .Range("e3").Value = "Delivery No:"
                    .Range("a3,d2,e3").Font.Bold = True
                    .Columns.AutoFit
                    .Name = CStr(dic.keys()(i))
                End With
            Next
            .SaveAs Replace(ThisWorkbook.Name, ".xlsm", " " & Format$(myDate, "yyyymmdd") & ".xlsx")
        End With
    Else
        MsgBox "No data"
    End If
End Sub

Works well, only thing is the columns on the generated excel file are not auto-fitted on every sheet. Some are, some aren't, not sure why. Maybe some line which autofits all column B's in the new Workbook?

Working perfectly here.

Ah right, it works on my sample one, but doesn't appear to be working on my actual one. If its ok, could I give you the real file with the macro inserted, I cannot figure out why it doesn't work on that.

Say I wanted to set the column width for column B of each of the generated sheets, I would insert

Columns("B").ColumnWidth = 25

So I'd end up with

Option Explicit

Sub test()
    Dim dic As Object, myDate, a, i As Long, e, flg As Boolean, x As Range, t As Long
    Dim r As Range
    Set r = Application.InputBox("Select cell that has the date to pick", Type:=8)
    If Not IsDate(r.Value) Then
        MsgBox "Invalid entry": Exit Sub
    End If
    myDate = r.Value
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1").Range("a3").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            For Each e In Array(4, 8, 12)
                If a(i, e) = myDate Then
                    flg = True: Exit For
                End If
            Next
            If flg Then
                If x Is Nothing Then Set x = .Rows(1).Columns("a:b")
                If Not dic.exists(a(i, 1)) Then
                    Set dic(a(i, 1)) = .Rows(1).Columns("a:b")
                End If
                Set dic(a(i, 1)) = Union(dic(a(i, 1)), .Rows(i).Columns("a:b"))
                Set x = Union(x, .Rows(i).Columns("a:b")): flg = False
            End If
        Next
    End With
    If Not x Is Nothing Then
        With Workbooks.Add
            x.Copy .Sheets(1).Range("a3")
            With .Sheets(1)
                .Range("c1").Value = myDate
                .Range("c1").Font.Bold = True
                With .Range("a3").CurrentRegion
                End With
                .Columns.AutoFit
                Columns("B").ColumnWidth = 25
            End With
            For i = 0 To dic.Count - 1
                If .Sheets.Count < i + 2 Then
                    .Sheets.Add after:=.Sheets(.Sheets.Count)
                End If
                With .Sheets(i + 2)
                    dic.items()(i).Copy .Range("a5")
                    .Range("d2").Value = myDate
                    .Range("a3").Value = "Name:"
                    .Range("e3").Value = "Delivery No:"
                    .Range("a3,d2,e3").Font.Bold = True
                    .Columns.AutoFit
                    Columns("B").ColumnWidth = 25
                    .Name = CStr(dic.keys()(i))
                End With
            Next
            .SaveAs Replace(ThisWorkbook.Name, ".xls", " " & Format$(myDate, "yyyymmdd") & ".xls")
        End With
    Else
        MsgBox "No data"
    End If
End Sub

But it only appears to set Column B to 25 for Sheet 1, and then misses the 2nd and 3rd sheet, then the rest are set to 25. Have I also to insert that code at another point?

Add a period before those lines.

i.e

.Columns("B").ColumnWidth = 25

Ok so this is my (nearly) finalised code for my main sheet, but one problem I have is that when I select a date which has many, many patients going out on it, like 150+, the Sheet 1 is a bit messed up, and it starts to get printed out on multiple sheets, with the branch code and customer name being split.
Is there a way to try to fit the names on one page, then when it detects there isn't enough space, it starts a new page and pastes more there and so on?

I increased the size of the testing file to illustrate it, and modified the code to roughly where I want it, but cannot figure out how I should get Sheet 1 how I want it.
As an example, select a date like 3/12/2013 which has a lot of customers with that date and you'll see what I mean. really appreciate the help so far.

Anyone able to help? Thats pretty much the only thing missing from it and then it'll be perfect.