时间戳

首页 > 解决方案 > 在 VBA 中查找字符串并根据不同的标准引入新数据

excel - 在 VBA 中查找字符串并根据不同的标准引入新数据

问题描述

目前，我有一个脚本，它从各种工作簿中获取数据，并根据“上次运行日期”将它们放在我的主报告中的特定位置。

这些工作簿的范围有所改变。现在，不再只是在工作簿（2021 年 10 月 25 日）中找到要粘贴到最后一个日期下方的 ONE DATE，而是需要将 30 天粘贴在现有日期之上。

例如，2021 年 10 月 25 日工作簿中包含2021 年 9 月 25 日至 2021 年10 月 25 日的数据（30 天）。我的主要工作簿中包含 2021 年 10 月 24 日之前的数据。它应该从第二行复制10-25-2021 工作簿中的数据（所有选择向下到右侧）并将其粘贴到主工作簿中，它会在其中找到 9-25-2021 及以下的第一行。这应该足以填充所有现有数据并继续缺失的日期，因为数据每天都遵循相同的行号/列。

知道怎么做吗？

非常感谢。

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

标签： excelvba

解决方案

从复制范围的单元格 (1) 中获取新数据的开始日期。使用查找在报告表的 A 列中搜索该日期，如果找到，将复制的数据粘贴到其中。

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

推荐阅读