excel 将数据从每月文件夹复制到工作表中(无需打开和关闭工作簿)

iecba09b  于 2023-06-25  发布在  其他
关注(0)|答案(1)|浏览(111)

我有一个每月的日记,我完成每个月,我需要复制数据从每日工作簿到另一个工作表,我通常这样做,但理想情况下想运行一个代码,所以我可以只做一次,而不是一个月?
我目前有一个代码,这将只为当前一天,但它打开和关闭当前的天数表这样做,理想情况下,我想它不打开和关闭文件,也能够一个月的数据,而不是如果这是可能的?所以它只是从当月文件夹中的所有工作表中获取所有数据。
请查看下面的当前代码:

Sub getlatestfilename()
  Dim F As String, folder As String, currentyear As Integer, currentmonth As String, foldername As String, myfile As String
  Dim LatestFile As String, filetoopen As String
  Dim LatestDate As Date
  Dim LMD As Date
  Dim LR As Long
  Dim datawb As Workbook, thiswb As Workbook, ws As Worksheet
  
  ' uncomment below once happy it runs
  Application.ScreenUpdating = False
  
  
  Set thiswb = ActiveWorkbook
  
  currentyear = Year(Date)
  currentmonth = Format(Month(Date), "00")
  
  
  
  folder = "K:\Finance\Protected Funding Sheets\Barclays cash funding\Daily Funding Calculation\" & currentyear '& "\"
  
  F = Dir(folder & "\*", vbDirectory)
  Do While F <> ""
    If InStr(F, currentmonth) > 0 Then
        foldername = F
        'Debug.Print foldername
        folder = folder & "\" & foldername & "\"
        Exit Do
    End If
    F = Dir
  Loop
  
  ' check the month folder has been found
  If F = "" Then
    MsgBox "No " & currentmonth & " folder found..... ", vbExclamation
    Exit Sub
  End If
  'Debug.Print folder
      
    
    'Make sure that the path ends in a backslash
    If Right(folder, 1) <> "\" Then folder = folder & "\"
    
    'Get the first Excel file from the folder
    myfile = Dir(folder & "*.xlsx", vbNormal)
    
    'If no files were found, exit the sub
    If Len(myfile) = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If
    
    'Loop through each Excel file in the folder
    Do While Len(myfile) > 0
    
        'Assign the date/time of the current file to a variable
        LMD = FileDateTime(folder & myfile)
        
        'If the date/time of the current file is greater than the latest
        'recorded date, assign its filename and date/time to variables
        If LMD > LatestDate Then
            LatestFile = myfile
            LatestDate = LMD
        End If
        
        'Get the next Excel file from the folder
        myfile = Dir
        
    Loop
    
    'Debug.Print LatestFile, LatestDate,
    
    filetoopen = folder & LatestFile
    
    'Debug.Print filetoopen
    Set datawb = Workbooks.Open(filetoopen, Password:="barclays")
    
    'select the correct sheet
    'change sheetname to what is used in the file
    'datawb.Sheets("sheetname").Activate
    
    With datawb.Sheets("Journal")
    date1 = .Range("B1")
    date2 = .Range("C1")
    bca = .Range("C16")
    bcabs41 = .Range("H19")
    bcabs42 = .Range("H20")
    csh = .Range("K15")
    cshbs42 = .Range("O15")
    cshbs43 = .Range("O16")
    cshbs432 = .Range("O18")
    cshbs44 = .Range("O19")
    'add the other required cells
    End With
    
    
    datawb.Close savechanges = False
    Set ws = thiswb.Sheets("Postings")
    ws.Activate
    
    'For understanding LR = Last Row
    'add variables data to the last row + 1
     With ws
     LR = .Cells(Rows.Count, 1).End(xlUp).Row
    'add the saved variables
    .Cells(LR + 1, 1) = date1
    .Cells(LR + 1, 2) = date2
    .Cells(LR + 1, 3) = bca
    .Cells(LR + 1, 4) = bcabs41
    .Cells(LR + 1, 5) = bcabs42
    .Cells(LR + 1, 6) = csh
    .Cells(LR + 1, 7) = cshbs42
    .Cells(LR + 1, 8) = cshbs43
    .Cells(LR + 1, 9) = cshbs432
    .Cells(LR + 1, 10) = cshbs44
    
    
    'add the other required cells
    End With
    
    Application.ScreenUpdating = True
End Sub

任何帮助将非常感谢。

ycggw6v2

ycggw6v21#

您已经有了一段代码,可以循环访问文件夹中的所有文件:

'Loop through each Excel file in the folder
Do While Len(myfile) > 0
   ...    
Loop

不要只在这个循环中分配LatestFile,而是将所有复制/粘贴活动都放在这个循环中。

Sub getlatestfilename()
  Dim F As String, folder As String, currentyear As Integer, currentmonth As String, foldername As String, myfile As String
  Dim LatestFile As String, filetoopen As String
  Dim LatestDate As Date
  Dim LMD As Date
  Dim LR As Long
  Dim datawb As Workbook, thiswb As Workbook, ws As Worksheet
  
  ' uncomment below once happy it runs
  Application.ScreenUpdating = False
  
  
  Set thiswb = ActiveWorkbook
  
  currentyear = Year(Date)
  currentmonth = Format(Month(Date), "00")
  
  
  
  folder = "K:\Finance\Protected Funding Sheets\Barclays cash funding\Daily Funding Calculation\" & currentyear '& "\"
  
  F = Dir(folder & "\*", vbDirectory)
  Do While F <> ""
    If InStr(F, currentmonth) > 0 Then
        foldername = F
        'Debug.Print foldername
        folder = folder & "\" & foldername & "\"
        Exit Do
    End If
    F = Dir
  Loop
  
  ' check the month folder has been found
  If F = "" Then
    MsgBox "No " & currentmonth & " folder found..... ", vbExclamation
    Exit Sub
  End If
  'Debug.Print folder
      
    
    'Make sure that the path ends in a backslash
    If Right(folder, 1) <> "\" Then folder = folder & "\"
    
    'Get the first Excel file from the folder
    myfile = Dir(folder & "*.xlsx", vbNormal)
    
    'If no files were found, exit the sub
    If Len(myfile) = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If
    
    'Loop through each Excel file in the folder
    Do While Len(myfile) > 0
    

        filetoopen = folder & myfile
        
        'Debug.Print filetoopen
        Set datawb = Workbooks.Open(filetoopen, Password:="barclays")
        
        'select the correct sheet
        'change sheetname to what is used in the file
        'datawb.Sheets("sheetname").Activate
        
        With datawb.Sheets("Journal")
        date1 = .Range("B1")
        date2 = .Range("C1")
        bca = .Range("C16")
        bcabs41 = .Range("H19")
        bcabs42 = .Range("H20")
        csh = .Range("K15")
        cshbs42 = .Range("O15")
        cshbs43 = .Range("O16")
        cshbs432 = .Range("O18")
        cshbs44 = .Range("O19")
        'add the other required cells
        End With
        
        
        datawb.Close savechanges = False
        Set ws = thiswb.Sheets("Postings")
        ws.Activate
        
        'For understanding LR = Last Row
        'add variables data to the last row + 1
         With ws
         LR = .Cells(Rows.Count, 1).End(xlUp).Row
        'add the saved variables
        .Cells(LR + 1, 1) = date1
        .Cells(LR + 1, 2) = date2
        .Cells(LR + 1, 3) = bca
        .Cells(LR + 1, 4) = bcabs41
        .Cells(LR + 1, 5) = bcabs42
        .Cells(LR + 1, 6) = csh
        .Cells(LR + 1, 7) = cshbs42
        .Cells(LR + 1, 8) = cshbs43
        .Cells(LR + 1, 9) = cshbs432
        .Cells(LR + 1, 10) = cshbs44
        
        
        'add the other required cells
        End With
        
        'Get the next Excel file from the folder
        myfile = Dir
        
    Loop
    
    
    
    Application.ScreenUpdating = True
End Sub

相关问题