Copy data from worksheets based on a cell entry

[Sparky]

I have data in a worksheet named Shortages, each entry is preceded with the current date (UK format). What I would like to achieve is to enter a chosen date into cell A1 in a sheet named Review (same workbook) and all entries in the Shortages sheet with the chosen date then copy across into the Review worksheet.

The date in the Shortages sheet appears in column B, I would like the data from column B to column G copied across to the Review sheet.

Hope anyone out there can help with this.

Thanks in advance

 

[Nogslaw]

I'm sure this can be done if that's really how you want to go about it, but why not just filter your existing list?

 

[Sparky]

Thanks for the quick reply but filtering is not an option as the data that I require to be copied across WILL contain other information such as part numbers that will be counted via formulas.

 

[Nogslaw]

Then something like this should work. You'll need to adjust the Ranges to fit your needs. Right-click the sheet tab name and select View Code. In the window that opens, paste the following:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" Then Exit Sub '$A$1 IS WHERE I ENTER THE DATE

Dim sh1 As Worksheet, sh2 As Worksheet, LR As Long, TR As Long, PR As Long
Set sh1 = Sheets("Review")  'SHEET WHERE REVIEW INFO WILL BE PASTED
Set sh2 = Sheets("Shortages")  'SHEET WHERE DATA RESIDES
LR2 = sh2.Range("B" & Rows.Count).End(xlUp).Row 'LAST ROW ON SHEET2
PR = 3 'FIRST ROW NUMBER ON SHEET1 WHERE DATA WILL BE PASTED
sh1.Range("A3:F" & Rows.Count).ClearContents 'CLEAR OUT OLD DATA

For Each cell In sh2.Range("B2:B" & LR2).Cells 'STARTS IN ROW 2, ASSUMING HEADERS IN ROW 1
    If cell.Value = Target.Value Then
        TR = cell.Row
        sh2.Range("B" & TR & ":G" & TR).Copy
        sh1.Range("A" & PR).PasteSpecial (xlPasteAll)
        PR = PR + 1 'MOVE TO NEXT PASTE ROW
    End If
Next cell

End Sub

 

[Sparky]

Nogslaw

Thanks for your time spent on this thread it works fine. I will try it in work tomorrow.

Once again thank you.