VBA复制另一个Excel文件内容到当前工作簿
这是我想要实现的：
我想复制在指定的目录中最近修改的Excel文件中的整个第一张工作表的内容。 然后，我想将此复制操作的值粘贴到当前工作簿的第一个工作表。
我知道有macros来获取目录中的最后一个修改的文件，但我不确定一个快速，干净的方式来实现这一点。
见下文。 这将使用当前活动的工作簿，并在C:\Your\Path查找具有最新修改date的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