VBA copy date

[sna]

Hi Dear

I try to write code to loop through files in a folder path.
The file name located in cell of column AD.i want to find if cell value in column AD match file name in the folder path it would loop through sheet to find date from column K or L if column N=0 and column O >0 then offset one row until column N>0 and column O>0 then return date from that row and place date on column AG.if file not found place file not found on AG.and if the data is blank place no data on AG too
Best wishes,


I also attached working file

[sna]

One more thing if data on col AG same as date col in U place OK on col AJ

[snasui]

I try to write code to loop through files in a folder path.
The file name located in cell of column AD

Could you please attach some file on column AD for test your code?

[sna]

Hi Dear

Here is an attached file

Best wishes

[snasui]

Try with this code.

Code: Select all

Sub Import_StartDate()
    Dim wk As Workbook, path As String, Fname As String
    Dim Rng As Range, Dn As Range, Cel As Range
    Dim Ng As Range, Fdt As Range
    Dim Dt As Range, SRn As String
    Dim Vdt As String, FileName As String
    Dim ThisWb As String, Ndata As Double
    Dim i As Long, j As Long
    
    ThisWb = ThisWorkbook.Name
    
    path = "\\op023\Data Center\OPERATION DEPARTMENT\4- CENTRALIZED OPERATION UNIT\4- Restructure Loan in 2020\Schedule Before and After\"
    
    Set Rng = RST1.Range(Range("AD3"), Range("AD" & Rows.Count).End(xlUp))
    
    For Each Dn In Rng
        Fname = Dn & ".xlsx"
        FileName = VBA.FileSystem.Dir(path & Fname)
        If FileName = VBA.Constants.vbNullString Then
            Dn.Offset(0, 3) = "File not found"
        Else
            Set wk = Workbooks.Open(path & Fname)
            Ndata = Range("K" & Rows.Count).End(xlUp).Row
            If Ndata < 3 Then
                Dn.Offset(0, 3) = "No DATA"
                wk.Close SaveChanges:=False
            Else
                Set Cel = Range(Range("K1"), Range("K" & Ndata))
                j = 0
                For i = Cel.Rows.Count To 1 Step -1
                    If Cel(i).Offset(0, 3).Value = 0 And Cel(i).Offset(0, 4) > 0 Then
                        Dn.Offset(0, 3).Value = Cel(i).Offset(1, 0).Value
                        j = j + 1
                        wk.Close False
                        Exit For
                    End If
                Next i
            End If
        End If
        If j = 0 Then
            Dn.Offset(0, 3) = "No DATA"
        End If

        ThisWorkbook.Activate
    Next Dn
    Call MsgBox("Transtion Completed !!!", vbInformation)
End Sub

[sna]

Thank you so much

[sna]

One more thing

Code: Select all

Sub Checking ()
Dim ThisCell1 As Range
Dim ThisCell2 As Range
    For Each ThisCell1 In Range("AG3:AG9999")
    'This is the range of cells to check
        For Each ThisCell2 In Range("U3:U9999")
        'This is the range of cells to compare
            If ThisCell1.Value = ThisCell2.Value Then
                ThisCell1.Offset(, 3).Value = "TRUE"
                Exit For
                End If
            Next ThisCell2
        Next ThisCell1

This process is slow what's wrong?


Best regards

[snasui]

This code loop many cells (9997 * 9997).

[sna]

How to fix this?

Thanks

[snasui]

Your code should scope only data not fixed range.

[sna]

Ok thanks