这就是我想要实现的目标:
我想将整个第一张表的内容复制到指定目录中最近修改的 excel 文件中。然后,我想将此复制操作的值粘贴到当前工作簿的第一张纸上。
我知道有宏可以获取目录中最后修改的文件,但我不确定实现这一点的快速而干净的方法。
见下文。这将使用当前活动的工作簿并查找C:\Your\Path
具有最新修改日期的 Excel 文件。然后它将打开文件并从第一张表中复制内容并将它们粘贴到您的原始工作簿中(在第一张表上):
Dim fso, fol, fil
Dim wkbSource As Workbook, wkbData As Workbook
Dim fileData As Date
Dim fileName As String, strExtension As String
Set wkbSource = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set fol = fso.GetFolder("C:\Your\Path")
fileData = DateSerial(1900, 1, 1)
For Each fil In fol.Files
strExtension = fso.GetExtensionName(fil.Path)
If Left$(strExtension, 3) = "xls" Then
If (fil.DateLastModified > fileData) Then
fileData = fil.DateLastModified
fileName = fil.Path
End If
End If
Next fil
Set wkbData = Workbooks.Open(fileName, , True)
wkbData.Sheets(1).Cells.Copy
wkbSource.Sheets(1).Range("A1").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
wkbData.Close
Set fso = Nothing
Set fol = Nothing
Set flc = Nothing
Set wkbData = Nothing
我的午餐没有更好的事情可做——所以就这样吧。
要触发它,请使用:getSheetFromA()
把它放在当前文件中:
Dim most_recent_file(1, 2) As Variant
Sub getSheetFromA()
' STEP 1 - Delete first sheet in this workbook
' STEP 2 - Look through the folder and get the most recently modified file path
' STEP 3 - Copy the first sheet from that file to the start of this file
' STEP 1
' Delete the first sheet in the current file (named incase if deleting the wrong one..)
delete_worksheet ("Sheet1")
' STEP 2
' Now look for the most recent file
Dim folder As String
folder = "C:\Documents and Settings\Chris\Desktop\foldername\"
Call recurse_files(folder, "xls")
' STEP 3
Dim most_recently_modified_sheet As String
most_recently_modified_sheet = most_recent_file(1, 0)
getSheet most_recently_modified_sheet, 1
End Sub
Sub getSheet(filename As String, sheetNr As Integer)
' Copy a sheet from an external sheet to this workbook and put it first in the workbook.
Dim srcWorkbook As Workbook
Set srcWorkbook = Application.Workbooks.Open(filename)
srcWorkbook.Worksheets(sheetNr).Copy before:=ThisWorkbook.Sheets(1)
srcWorkbook.Close
Set srcWorkbook = Nothing
End Sub
Sub delete_worksheet(sheet_name)
' Delete a sheet (turn alerting off and on again to avoid prompts)
Application.DisplayAlerts = False
Sheets(sheet_name).Delete
Application.DisplayAlerts = True
End Sub
Function recurse_files(working_directory, file_extension)
With Application.FileSearch
.LookIn = working_directory
.SearchSubFolders = True
.filename = "*." & file_extension
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
number_of_files = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
vFile = .FoundFiles(i)
Dim temp_filename As String
temp_filename = vFile
' the next bit works by seeing if the current file is newer than the one in the array, if it is, then replace the current file in the array.
If (most_recent_file(1, 1) <> "") Then
If (FileLastModified(temp_filename) > most_recent_file(1, 1)) Then
most_recent_file(1, 0) = temp_filename
most_recent_file(1, 1) = FileLastModified(temp_filename)
End If
Else
most_recent_file(1, 0) = temp_filename
most_recent_file(1, 1) = FileLastModified(temp_filename)
End If
Next i
Else
MsgBox "There were no files found."
End If
End With
End Function
Function FileLastModified(strFullFileName As String)
' Taken from: http://www.ozgrid.com/forum/showthread.php?t=27740
Dim fs As Object, f As Object, s As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(strFullFileName)
s = f.DateLastModified
FileLastModified = s
Set fs = Nothing: Set f = Nothing
End Function