Finding String in VBA and introducing new data based on different criterias-CodePudding

Currently, I have a script that takes data from various workbooks and puts them at specific places in my main report, based on the 'last run date'.

Those workbooks changed in scope a bit. Now, in stead of ONE DATE only that was found in the workbooks(10-25-2021) to be pasted below the last one, it is now 30 days that needs to be pasted on top of the existing ones.

e.g. 10-25-2021 Workbook has 9-25-2021 to 10-25-2021 data in it (30 days). My main workbook has data until 10-24-2021 in it. It should copy the data from 10-25-2021 Workbook from the second line (all selection down to the right) and paste it in the Main Workbook where it finds the first line of 9-25-2021 and below. This should be good enough to fill all the existing data and continue with the missing date since the data follows the same row number/columns every day.

Any idea how to do it?

Thanks a lot.

Sub Code()

Dim wb1 As Workbook
Dim raspuns As String

Const FOLDER_PATH = "\\emag.local\ro\Financial\Controlling&Reporting\Reporting\6_Marketing\FY_2021\Budget\RO\Drivers\Input Daily Reports"

Dim FSO As Object, fld
Dim dtLastRun As Date

Application.ScreenUpdating = False
   
    
ThisWorkbook.Worksheets("PPV").Activate
dtLastRun = ActiveSheet.Range("A700000").End(xlUp)

Set FSO = CreateObject("Scripting.FileSystemObject")

For Each fld In FSO.getfolder(FOLDER_PATH).SubFolders
        If (fld.Name > Format(dtLastRun, "yyyy_mm_dd")) And _
           (fld.Name <= Format(Now, "yyyy_mm_dd")) Then
                    



    Set wb1 = Workbooks.Open("\" & fld & "\PPV.csv")
        wb1.Worksheets("PPV").Activate

        wb1.Worksheets("PPV").Range("a2", Range("a2").End(xlDown).End(xlToRight)).Select
        Selection.Copy
        
        
    ThisWorkbook.Worksheets("PPV").Activate
    
    lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ActiveSheet.Cells(lastrow   1, 1).Select
    ActiveSheet.Paste
    
    Application.CutCopyMode = False
    
    wb1.Close SaveChanges:=False
    
    
   

Set wb1 = Nothing
Set lastrow = Nothing

CodePudding user response：

Get the start date for the new data from cell(1) of the copied range. Search for that date in column A on the report sheet using Find and if found, paste the copied data into it.

Option Explicit

Sub Code()
    Const FOLDER_PATH = '\\emag.local\ro\Financial\Controlling&Reporting\Reporting\6_Marketing\FY_2021\Budget\RO\Drivers\Input Daily Reports"
    
    Dim wb As Workbook, wsPPV As Worksheet
    Dim FSO As Object, fld, lastrow As Long
    Dim rngSrc As Range, rngTarget As Range
    Dim dtLastRun As Date, dtStart As Date

    Set wb = ThisWorkbook
    Set wsPPV = wb.Sheets("PPV")
    dtLastRun = wsPPV.Cells(Rows.Count, "A").End(xlUp).Value2
    MsgBox "Last run was " & Format(dtLastRun, "dd-mmm-yyyy")

    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each fld In FSO.getfolder(FOLDER_PATH).SubFolders

        If (fld.Name > Format(dtLastRun, "yyyy_mm_dd")) And _
            (fld.Name <= Format(Now, "yyyy_mm_dd")) Then
                 
            ' open workbook and get start date
            Set wb = Workbooks.Open("\" & fld & "\PPV.csv")
            Set rngSrc = wb.Sheets("PPV").Range("A2", Range("A2").End(xlDown).End(xlToRight))
            dtStart = rngSrc.Cells(1)
        
            ' find start date on wsPPV and paste
            Set rngTarget = wsPPV.Range("A:A").Find(dtStart, LookIn:=xlFormulas, lookAt:=xlWhole)
            If rngTarget Is Nothing Then
                MsgBox "Start Date " & Format(dtStart, "dd-mmm-yyyy") & " not found", vbCritical, dtStart
            Else
                rngSrc.Copy rngTarget
                Application.CutCopyMode = False
                MsgBox fld & " " & rngSrc.Address & " copied to " & rngTarget.Address
            End If
           
            wb.Close SaveChanges:=False
        
        End If
    Next
End Sub