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

[PA_VA13]

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]

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]

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]

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]

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]

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]

Hi vcoolio!

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

PA_VA13

 

[vcoolio]

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

Cheerio,
vcoolio.

 

[PA_VA13]

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]

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.