copy selected cells in a row/s to another worksheet based on date-VBA

[dibyendu]

Hello,

I need to copy data from worksheet "Records" to worksheet "Reviews" based on date (msg. box= which date?).
In worksheet "Records" date is in column "BV". I need to copy column "C", "D","BU", "BV","BW", "BX" from worksheet "Records" when particular date of interest matches and paste it to column "A", "B", "C", "D", "E", "F" of worksheet "Reviews"(The first row should remain blank for adding "Headings"). Evey time when VBA runs the previous data in worksheet "Reviews" should be clear(delete). The VBA code needs to search from 10,000 rows from worksheet "Records". I am new to VBA and need your support. Thanks for your support.

 

[dibyendu]

The following code works but it takes long time to execute. Any idea to make the VBA better.

Sub FindNext_Copy_Data()


Worksheets("Reviews").Unprotect ("ds12345678")
Sheets("Reviews").Columns("A:H").ClearContents
Dim ws1 As Worksheet, ws2 As Worksheet
Dim AllCells As Range, Cell As Range
Dim n&, Mydate As Date
Application.ScreenUpdating = False
Set ws1 = Sheets("Records"): Set ws2 = Sheets("Reviews"): Mydate = InputBox("Which Date ? MM/DD/YYYY"): ws1.Select 'added select sheet1
Set AllCells = ws1.Range("VB1", Range("G65536").End(xlUp))
n = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each Cell In AllCells
With Cell
If Cell = Mydate Then
Cell.EntireRow.Copy Destination:=ws2.Cells(n, 1): n = n + 1
End If
End With
Next Cell
ws2.Select: Set ws1 = Nothing: Set ws2 = Nothing: Set AllCells = Nothing
Application.ScreenUpdating = True
Range("A:B").EntireColumn.ClearContents
Range("E:BT").EntireColumn.Delete
Range("C2:H50").Sort _
Key1:=Range("E2"), Order1:=xlAscending
[C1] = "NAME OF THE PATIENT"
[D1] = "REG. NO."
[E1] = "DEPARTMENT"
[F1] = "DATE OF REVIEW"
[G1] = "TIME OF REVIEW"
[H1] = "PHONE NUMBER"
Worksheets("Reviews").Protect ("ds12345678")


End Sub

 

[Fluff]

Hi
This is based primarily on your description in post#1 rather than your macro in post#2, as they differ

Sub FindNext_Copy_Data()

    Dim RecSht As Worksheet
    Dim RevSht As Worksheet
    Dim Mydate As Date
    
    Application.ScreenUpdating = False

    Set RecSht = Sheets("Records")
    Set RevSht = Sheets("Reviews")

    RevSht.Unprotect ("ds12345678")
    RevSht.Columns("A:H").ClearContents
    Mydate = InputBox("Which Date ? MM/DD/YYYY")

    RecSht.Range("BV:BV").AutoFilter
    With RecSht.Range("BV:BV")
        .AutoFilter Field:=1, Criteria1:=Format(Mydate, "DD/MM/YYYY")
        RecSht.Range("C:D,BU:BX").SpecialCells(xlVisible).Copy RevSht.Range("A1")
    End With
    RecSht.Range("A1").AutoFilter

    RevSht.Activate
    Range("A2", Range("F" & Rows.Count).End(xlUp)).Sort _
    Key1:=Range("C2"), Order1:=xlAscending
    [A1] = "NAME OF THE PATIENT"
    [B1] = "REG. NO."
    [C1] = "DEPARTMENT"
    [D1] = "DATE OF REVIEW"
    [E1] = "TIME OF REVIEW"
    [F1] = "PHONE NUMBER"
    RevSht.Protect ("ds12345678")


End Sub

 

[dibyendu]

The above code gives " Run-time error '1004' Application-defined or object-defined error"

 

[Fluff]

What line is highlighted when you click Debug?

 

[dibyendu]

RecSht.Range("BV:BV").AutoFilter

 

[Fluff]

This beats me
I cant replicate this error at all.
As a matter of interest, did you put the code in a standard module?

 

[dibyendu]

When I unprotect Sheet "Records", the VBA code runs without error. The code cannot run in passward protected worksheet. Also when I run the code it does not give any result in worksheet "Reviews" (when I hit a known date). Worksheet "Reviews" remains blank.

 

[Fluff]

Also when I run the code it does not give any result in worksheet "Reviews" (when I hit a known date). Worksheet "Reviews" remains blank.

My mistake, because my dates are DD/MM/YY I need to format the date in the filter Criteria & I forgot to remove it.
Try

Sub FindNext_Copy_Data()

    Dim RecSht As Worksheet
    Dim RevSht As Worksheet
    Dim Mydate As Date
    
    Application.ScreenUpdating = False

    Set RecSht = Sheets("Records")
    Set RevSht = Sheets("Reviews")
    
    RecSht.Unprotect ("[COLOR=#ff0000]Pword[/COLOR]")
    RevSht.Unprotect ("ds12345678")
    RevSht.Columns("A:H").ClearContents
    Mydate = InputBox("Which Date ? MM/DD/YYYY")

    RecSht.Columns("BV").AutoFilter
    With RecSht.Range("BV:BV")
        .AutoFilter Field:=1, Criteria1:=Mydate
        RecSht.Range("C:D,BU:BX").SpecialCells(xlVisible).Copy RevSht.Range("A1")
    End With
    RecSht.Range("A1").AutoFilter

    RevSht.Activate
    Range("A2", Range("F" & Rows.Count).End(xlUp)).Sort _
    Key1:=Range("C2"), Order1:=xlAscending
    [A1] = "NAME OF THE PATIENT"
    [B1] = "REG. NO."
    [C1] = "DEPARTMENT"
    [D1] = "DATE OF REVIEW"
    [E1] = "TIME OF REVIEW"
    [F1] = "PHONE NUMBER"
    RevSht.Protect ("ds12345678")
    RecSht.Protect ("[COLOR=#ff0000]Pword[/COLOR]")


End Sub

Also if you change the 2 bits in red, this will unprotect & reprotect the record sheet

 

[dibyendu]

After the change of 2 bits in red, the code is showing no error but the code after execution gives no result on sheet "Reviews" (on entering date which is present in sheet "Records" column "BV"