VBA Sort DIR按字母顺序传输数据

我已经在下面写了一个macros来将用户选定文件夹中的所有工作簿中的数据复制并粘贴到主文档中，但是当前macros以随机顺序select文件。 我想要做的是按字母顺序select文件，所以主文档中的数据是按照正确的顺序进行的……帮助实现这一点将是非常值得赞赏的，我对这种方法并不是很珍贵！

Sub Import_Data() ' PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them Dim WB As Workbook Dim wbThis As Workbook Dim myPath As String Dim myFile As String Dim myExtension As String Dim FldrPicker As FileDialog Set wbThis = ActiveWorkbook ' Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual ' Retrieve Target Folder Path From User MsgBox "Please select Faro Scan Data Folder" Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "Select A Target Folder" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode myPath = .SelectedItems(1) & "\" End With ' In Case of Cancel NextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings ' Target File Extension (must include wildcard "*") myExtension = "*.xls" ' Target Path with Ending Extention myFile = Dir(myPath & myExtension) ' Loop through each Excel file in folder Do While myFile <> "" ' Set variable equal to opened workbook Set WB = Workbooks.Open(Filename:=myPath & myFile) ' Ensure Workbook has opened before moving on to next line of code DoEvents ' Copy data from target workbook.... WB.Activate Application.CutCopyMode = False Range("D8:D377").Copy wbThis.Activate Sheets("Faro Scan Data").Select Range("E5").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ' Insert column for next data set Columns("E:E").Select Selection.Insert Shift:=xlToRight ' Format column for new dataset Columns("I:I").Select Selection.Copy Columns("E:E").Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ' Close Workbook WB.Close SaveChanges:=False ' Ensure Workbook has closed before moving on to next line of code DoEvents ' Get next file name myFile = Dir Loop ' Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: ' Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "Remeber to enter column headings!" End Sub 

Answer 1

看看下面的示例，展示如何使用filter循环浏览文件夹中的文件，并使用Shell.Application ActiveX按字母顺序sorting：

 Option Explicit Sub Test_Shell_Folder_Items() Dim sPath Dim sExtension Dim oShellApp Dim oFolder Dim oFolderItems Dim oFolderItem sPath = "C:\Test" sExtension = "*.xls" Set oShellApp = CreateObject("Shell.Application") Set oFolder = oShellApp.Namespace(sPath) Set oFolderItems = oFolder.Items() oFolderItems.Filter 64 + 128, sExtension ' 32 - folders, 64 - not folders, 128 - hidden For Each oFolderItem In oFolderItems Debug.Print oFolderItem.Path Next End Sub