Error after date: 10-10-2021

[m gruwel]

I wrote and starting using the code at the start of 2021. Somewere around 2-2021. It worked perfect until two weeks ago. I think it has something to do with the date value, for it does not work after 09-10-2021.
the code works as follows:
I enter a date in B3 sheet AFVAL_TOT. In sheet AFVAL_DATA is a list ranging from 1-1-2021 to 31-12-2021. when i press the button (which starts the code) it will take the values from worksheet AFVAL_TOT and copy it to worksheet AFVAL_DATA in the list with dates behind the date thats corresponds with the date from B3.


Sub Knop()
Dim rFndCell As Range
Dim stFnd As Date
Dim fRow As Long
Dim sh As Worksheet
Dim ws As Worksheet

Set ws = Sheets("AFVAL_TOT")
Set sh = Sheets("AFVAL_DATA")
stFnd = Range("B3")

With sh
Set rFndCell = .Range("D2:D366").Find(stFnd, LookIn:=xlValues)
If Not rFndCell Is Nothing Then
fRow = rFndCell.Row
ws.Range("C5,D5").Copy sh.Cells(fRow, 5)
ws.Range("C6,D6").Copy sh.Cells(fRow, 7)
ws.Range("C7,D7").Copy sh.Cells(fRow, 9)
ws.Range("C8,D8").Copy sh.Cells(fRow, 11)
ws.Range("C9,D9").Copy sh.Cells(fRow, 13)
ws.Range("C10,D10").Copy sh.Cells(fRow, 15)
ws.Range("C11").Copy sh.Cells(fRow, 17)
ws.Range("C12").Copy sh.Cells(fRow, 18)
ws.Range("C14,D14").Copy sh.Cells(fRow, 19)
MsgBox "Ok"
Else
MsgBox "Error"
End If
End With
End Sub

[snb]

Begin met het verwijderen van samengevoegde cellen.

[rollis13]

Hi to all.
Why does cell D285 of sheet AFVAL_DATA contain 01/01/2022 ?

[Paul_Hossler]

1. changed Knop() to specify the sheet, otherwise is assumes whatever sheet is currently active

2. ws data D285 should be "10/11/2021" (US format)




Option Explicit


Sub Knop()
Dim rFndCell As Range
Dim stFnd As Date
Dim fRow As Long
Dim sh As Worksheet
Dim ws As Worksheet

Set ws = Sheets("AFVAL_TOT")
Set sh = Sheets("AFVAL_DATA")

stFnd = ws.Range("B3").Value ' <<<<<<<<<<<<<<<<<<<<<<<<<

With sh
Set rFndCell = .Range("D2:D366").Find(stFnd, LookIn:=xlValues)

If Not rFndCell Is Nothing Then
fRow = rFndCell.Row
ws.Range("C5,D5").Copy sh.Cells(fRow, 5)
ws.Range("C6,D6").Copy sh.Cells(fRow, 7)
ws.Range("C7,D7").Copy sh.Cells(fRow, 9)
ws.Range("C8,D8").Copy sh.Cells(fRow, 11)
ws.Range("C9,D9").Copy sh.Cells(fRow, 13)
ws.Range("C10,D10").Copy sh.Cells(fRow, 15)
ws.Range("C11").Copy sh.Cells(fRow, 17)
ws.Range("C12").Copy sh.Cells(fRow, 18)
ws.Range("C14,D14").Copy sh.Cells(fRow, 19)
MsgBox "Ok"

Else
MsgBox "Error"
End If
End With
End Sub