VBA排序DIR以按字母顺序传输数据 [英] VBA Sort DIR to transfer data in alphabetical order

问题描述

我在下面编写了一个宏，用于将用户选择的文件夹中所有工作簿中的数据复制并粘贴到主文档中，但是当前该宏以随机顺序选择文件.我要做的是按字母顺序选择文件，因此主文档中的数据按正确的顺序...帮助实现这一点将非常感激，我对这种方法并不珍惜！

I have written a macro below to copy and paste data from all workbooks within a user selected folder into a master document, however currently the macro selects the files in a random order. What I want to do is for it to select the files in alphabetical order, so the data in the master document is in the correct order... Help achieving this would be much appreciated, I am not precious about the method!

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

推荐答案

看看下面的示例，该示例显示如何使用Shell.Application ActiveX循环过滤带有筛选器的文件夹中的文件并按字母顺序对其进行排序:

Take a look at the below example showing how you can loop through files in folder with filter and sorted in alphabetical order using Shell.Application ActiveX:

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

这篇关于VBA排序DIR以按字母顺序传输数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！