# Adding date variable to a search and copy/paste VBA code



## PA_VA13 (May 21, 2021)

Hi everyone,

I was able to create a Button (Assign Cases To SP) that would run a module with a VBA code to find matching case numbers in column A from each worksheet and then transfer the data from column D from worksheet "Assign" to column D in worksheet "SP".

I cannot figure out how to add a cross reference date check to this code to prevent data procured on a different date for the same accession number in worksheet "SP" from being overwritten. I need the code to check the date (ex: 5/24) in column C in worksheet "Assign" to column C in worksheet "SP". If the dates match, then I want the code to continue with the copy and pasting. If the dates do not match, then I want the code to leave those cells alone. Worksheet "SP" will often have multiple lines for one accession number with a different date, depending on when the procedure was performed for that part of the case.

I cannot use the L2BB feature as it is blocked on my work PC, but I did include screen captures of the excel sheet.

This is the code that I came up with so far.

*Button Code:*

Private Sub CommandButton1_Click()

    Call asd

End Sub

*Module Code:*

   Sub asd()

    Dim lngLastRowSht1 As Long
    Dim lngLastRowSht2 As Long
    Dim counterSht1 As Long
    Dim counterSht2 As Long

    With Worksheets("Assign")
        lngLastRowSht1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        lngLastRowSht2 = Worksheets("SP").Cells(Worksheets("SP").Rows.Count, 1).End(xlUp).Row
            For counterSht1 = 1 To lngLastRowSht1
                For counterSht2 = 1 To lngLastRowSht2
                    If .Cells(counterSht1, 1) = Worksheets("SP").Cells(counterSht2, 1) Then
                        Worksheets("SP").Cells(counterSht2, 4) = .Cells(counterSht1, 4)
                    End If
                Next counterSht2
            Next counterSht1
    End With

End Sub


----------



## vcoolio (May 22, 2021)

Hello PA_VA13,

This may help:-

```
Private Sub CommandButton1_Click()

    Dim lr As Long
    Dim sValue As Range, c As Range
   
Application.ScreenUpdating = False

            lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
            Sheet2.Range("D2:D" & lr).ClearContents
                   
    For Each c In Sheet1.Range("A2:A" & lr)
            Set sValue = Sheet2.Columns("A:A").Find(c.Value)
            If sValue Is Nothing Then GoTo Nextc
    If c.Value = sValue.Value And c.Offset(, 2).Value = sValue.Offset(, 2) Then
            c.Offset(, 3).Copy sValue.Offset(, 3)
    End If
Nextc:
    Next c

Sheet2.Select
Application.ScreenUpdating = True

End Sub
```

It should confirm that Case# and Date match in both sheets before transferring the initials.
Case numbers with non-matching dates will be overlooked as will blank date cells.
You don't need to call the code from a standard module. Just place the above code into the button module.

I hope that this helps.

Cheerio,
vcoolio.


----------



## PA_VA13 (May 26, 2021)

Hi vcoolio,

I finally had a chance at work to try the VBA code. I seem to get a Run-time error '424': Object required error for the lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row line. I believe this is because the worksheet names are "Assign" and "SP" and not Sheet1 and Sheet2. 

When I changed Sheet1 to Worksheet("Assign") and Sheet2 to Worksheet("SP") I received a Compile error: Sub or Function not defined and it highlighted the Private Sub CommandButton1_Click().

What did I do wrong?

Thanks again for your help!

PA_VA13


----------



## vcoolio (May 26, 2021)

Hello PA_VA13,

Change Worksheet("Assign") to Worksheets("Assign"). The same for the other worksheet.

Let us know if that sorted it out for you.

Cheerio,
vcoolio.


----------



## PA_VA13 (May 27, 2021)

HI vcoolio,

I fixed Worksheet("Assign") to Worksheets("Assign") and tried to run the code again. It gave me a Run-time error '1004': We can't do that to a merged cell. None of the cells in either worksheets are merged so I don't know what is triggering this error. It seems to not like the Worksheets("SP").Range("D2:D" & lr).ClearContents line in the code when I tried to debug it. 

Private Sub CommandButton1_Click()

    Dim lr As Long
    Dim sValue As Range, c As Range

Application.ScreenUpdating = False

            lr = Worksheets("Assign").Range("A" & Rows.Count).End(xlUp).Row
Worksheets("SP").Range("D2:D" & lr).ClearContents

    For Each c In Worksheets("Assign").Range("A2:A" & lr)
            Set sValue = Worksheets("SP").Columns("A:A").Find(c.Value)
            If sValue Is Nothing Then GoTo Nextc
    If c.Value = sValue.Value And c.Offset(, 2).Value = sValue.Offset(, 2) Then
            c.Offset(, 3).Copy sValue.Offset(, 3)
    End If
Nextc:
    Next c

Worksheets("SP").Select
Application.ScreenUpdating = True

End Sub


----------



## vcoolio (May 28, 2021)

Hello PA_VA13,

It's a bit baffling because it works just fine in a mock-up I created to test with. However, I really don't know how your actual workbook is set out so it would be a good idea for you to upload a sample of your workbook to a free file sharing site such as WeTransfer or Drop Box then post the link to your file back here. Make sure that the sample is an *exact *replica of your workbook in all aspects and, if your data is sensitive, then please use dummy data.

I have, though, picked up on a typo in the code:-

I have here the same last row variable used on both sheets:


```
lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
            Sheet2.Range("D2:D" & lr).ClearContents
```

The last row variable refers to sheet1 so we need one specifically for sheet2. So, change the code a little as follows:-


```
Private Sub CommandButton1_Click()

    Dim lr As Long, lr2 As Long
    Dim sValue As Range, c As Range
   
Application.ScreenUpdating = False

            lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
            lr2 = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
            Sheet2.Range("D2:D" & lr2).ClearContents
                   
    For Each c In Sheet1.Range("A2:A" & lr)
            Set sValue = Sheet2.Columns("A:A").Find(c.Value)
            If sValue Is Nothing Then GoTo Nextc
    If c.Value = sValue.Value And c.Offset(, 2).Value = sValue.Offset(, 2) Then
            c.Offset(, 3).Copy sValue.Offset(, 3)
    End If
Nextc:
    Next c

Sheet2.Select
Application.ScreenUpdating = True

End Sub
```

I have it in my mock-up but somehow removed it from the code in post #2.
Still supply a sample though.

Cheerio,
vcoolio.


----------



## PA_VA13 (May 28, 2021)

Hi vcoolio!

That fixed the issue. It works perfectly now. Thank you so much for all of your help!!!

PA_VA13


----------



## vcoolio (May 28, 2021)

You're welcome PA_VA13. I'm glad to have been able to assist and thanks for the feed back.

Cheerio,
vcoolio.


----------



## PA_VA13 (Jul 7, 2021)

Hi vcoolio,

The VBA code that you helped me with is working fantastically for my daily data entry. Thank you very much! Would you be able to assist me with a small (hopefully) edit to one area?

My Dr. would like to use the same VBA code in another excel sheet that holds the same type and format of data as in Sheet1 and Sheet2, but Sheet1 data is collected from multiple date entries throughout the year instead of just one day. The data in Sheet2 is collected daily and then needs to be transferred to Sheet1 like before. 

The part that I need to adjust in the code is the ClearContents line and I am not sure how to do that. I need the column D cells in Sheet1 cleared just for the column A cell Sheet2 values that are being copied for that day instead of clearing all of the data in column D. Is this even possible? Would I need to create some type of ClearContent script with a column A range variable? 

I will try uploading the excel sheets from my phone as my work PC somehow blocks L2BB.

Thank you very much for you assistance!

PA-VA13


----------



## vcoolio (Jul 7, 2021)

Hello PA_VA13,

Here's the code with a couple of instructions in green font for you:-

```
Sub Test()

    Dim lr As Long, lr2 As Long
    Dim sValue As Range, c As Range
    
Application.ScreenUpdating = False

                    lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
                    lr2 = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
                    Sheet2.Range("D2:D" & lr2).ClearContents  '---->Remove this line of code.
                    
        For Each c In Sheet1.Range("A2:A" & lr)
                    Set sValue = Sheet2.Columns("A:A").Find(c.Value)
                    If sValue Is Nothing Then GoTo Nextc
              If c.Value = sValue.Value And c.Offset(, 2).Value = sValue.Offset(, 2) Then
                    sValue.Offset(, 3).ClearContents  '---->Add this line of code.
                    c.Offset(, 3).Copy sValue.Offset(, 3)
              End If
Nextc:
        Next c

Sheet2.Select
Application.ScreenUpdating = True

End Sub
```

Hopefully, I've got it the right way round for you!

Cheerio,
vcoolio.


----------



## PA_VA13 (May 21, 2021)

Hi everyone,

I was able to create a Button (Assign Cases To SP) that would run a module with a VBA code to find matching case numbers in column A from each worksheet and then transfer the data from column D from worksheet "Assign" to column D in worksheet "SP".

I cannot figure out how to add a cross reference date check to this code to prevent data procured on a different date for the same accession number in worksheet "SP" from being overwritten. I need the code to check the date (ex: 5/24) in column C in worksheet "Assign" to column C in worksheet "SP". If the dates match, then I want the code to continue with the copy and pasting. If the dates do not match, then I want the code to leave those cells alone. Worksheet "SP" will often have multiple lines for one accession number with a different date, depending on when the procedure was performed for that part of the case.

I cannot use the L2BB feature as it is blocked on my work PC, but I did include screen captures of the excel sheet.

This is the code that I came up with so far.

*Button Code:*

Private Sub CommandButton1_Click()

    Call asd

End Sub

*Module Code:*

   Sub asd()

    Dim lngLastRowSht1 As Long
    Dim lngLastRowSht2 As Long
    Dim counterSht1 As Long
    Dim counterSht2 As Long

    With Worksheets("Assign")
        lngLastRowSht1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        lngLastRowSht2 = Worksheets("SP").Cells(Worksheets("SP").Rows.Count, 1).End(xlUp).Row
            For counterSht1 = 1 To lngLastRowSht1
                For counterSht2 = 1 To lngLastRowSht2
                    If .Cells(counterSht1, 1) = Worksheets("SP").Cells(counterSht2, 1) Then
                        Worksheets("SP").Cells(counterSht2, 4) = .Cells(counterSht1, 4)
                    End If
                Next counterSht2
            Next counterSht1
    End With

End Sub


----------



## PA_VA13 (Jul 8, 2021)

Hi vcoolio,

I worked perfectly. Thank you!

PA_VA13


----------



## vcoolio (Jul 8, 2021)

You're welcome PA_VA13. I'm glad to have been able to help again.

Cheerio,
vcoolio.


----------



## PA_VA13 (Jan 4, 2023)

Morning everyone,

I need some help. This VBA code that vcoolio helped me with worked beautifully all year in 2022, but for some reason it will not recognize dates for 2023. All of the data is located in the exact same format and cells (date cells are all in the same "Date" format; i.e. 12/30/2022 & 1/43/2023) for both sheets. The only difference is now I have dates ending in 2023. I did a test and if the date ends in 2022 the code performs like it should. I did not received any error messages. The code goes through all of the steps, but does not paste anything into sheet 2 if the date ends in 2023. 


Private Sub CommandButton1_Click()

    Dim lr As Long, lr2 As Long
    Dim sValue As Range, c As Range

Application.ScreenUpdating = False

            lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
            lr2 = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
            Sheet2.Range("D2:D" & lr2).ClearContents

    For Each c In Sheet1.Range("A2:A" & lr)
            Set sValue = Sheet2.Columns("A:A").Find(c.Value)
            If sValue Is Nothing Then GoTo Nextc
    If c.Value = sValue.Value And c.Offset(, 2).Value = sValue.Offset(, 2) Then
            c.Offset(, 3).Copy sValue.Offset(, 3)
    End If
Nextc:
    Next c

Sheet2.Select
Application.ScreenUpdating = True

End Sub


----------

