Datum in Bereich suchen und range kopieren

Sub listNames()



    Dim searchWs As Worksheet, searchWs2 As Worksheet, resultWs As Worksheet

    Dim searchrng As Range, rngfund As Range

    Dim arrfind, result

    Dim lrow&, i&, cnt&

    Dim searchval$



    searchval = "Format(Date, "dd.mm.yy") 'Funktioniert bei manueller/fester Eingabe

    Set searchWs = Worksheets("1-Suche")

    Set searchWs2 = Worksheets("2-Suche&KOPIEREhierHERAUS")

    Set resultWs = Worksheets("3-ERGEBNIS")

    

    Set searchrng = searchWs.UsedRange

    ReDim arrfind(1 To searchrng.Columns.Count)

     

    For i = 1 To searchrng.Columns.Count

        Set rngfund = searchrng.Columns(i).Find(What:=searchval, LookIn:=xlValues, lookat:=xlPart)

        If Not rngfund Is Nothing Then

            cnt = cnt + 1

            arrfind(cnt) = searchrng.Columns(i).Cells(1)

        End If

    Next

    ReDim Preserve arrfind(1 To cnt)

   

    If Not TypeName(arrfind) = "Empty" Then

       Application.ScreenUpdating = False

       lrow = resultWs.Cells(Rows.Count, 1).End(xlUp).Row

       cnt = 0

       

       For i = LBound(arrfind) To UBound(arrfind)

            result = Application.WorksheetFunction.Match(arrfind(i), searchWs2.UsedRange.Columns(1), 0)

            If IsNumeric(result) Then

                resultWs.Cells(lrow + cnt, 1).NumberFormat = "@"

                resultWs.Cells(lrow + cnt, 1).Resize(1, 4).Value = searchWs2.Cells(result, 1).Resize(1, 4).Value

                cnt = cnt + 1

            End If

       Next

       

    End If

   

End Sub

Sub CopyData



Dim lngLZ, lnglCOL, lnglROW As Long

Dim qws As Worksheet



Application.ScreenUpdating = False



lnglCOL = Sheets("FA-CALC").Cells(1, Columns.Count).End(xlToLeft).Column + 1

lngLZ = Sheets("FA-CALC").Range("O:O").Find(What:="*", LookIn:=xlValues, Lookat:=xlWhole, SearchDirection:=xlPrevious).Row



Sheets("FA-CALC").Range("O1:O" & lngLZ).Copy



With Sheets("1-Suche")

.Cells(1, lnglCOL).PasteSpecial Paste:=xlValues, Operation:=xlNone

.Cells(1, lnglCOL).PasteSpecial Paste:=xlFormats, Operation:=xlNone

End With



Application.ScreenUpdating = True



End Sub