وارد کردن چندین فایل به یک ورک بوک واحد

Question

بیایید بگوییم که شما یک پوشه در هارد دیسک خود دارید که حاوی سی فایل متنی است و می خواهید همه آنها را به یک ورک بوک اکسل وارد کنید. شما می خواهید که هر فایل متنی در کاربرگ خود در ورک بوک قرار گیرد، به طوری که در مجموع 30 کاربرگ داشته باشید.

یکی از راه های انجام این کار این است که کاربرگ های مورد نظر را به صورت دستی اضافه کنید و سپس هر یک از فایل های متنی را به صورت جداگانه وارد کنید. این، همانطور که می توانید تصور کنید، به سرعت خسته کننده خواهد شد. راه حل بسیار بهتر استفاده از ماکرو برای انجام واردات است، مانند مورد زیر.

Sub CombineTextFiles()
    Dim FilesToOpen
    Dim x As Integer
    Dim wkbAll As Workbook
    Dim wkbTemp As Workbook
    Dim sDelimiter As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    sDelimiter = "|"

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Text Files (*.txt), *.txt", _
      MultiSelect:=True, Title:="Text Files to Open")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    Set wkbTemp = Workbooks.Open(FileName:=FilesToOpen(x))
    wkbTemp.Sheets(1).Copy
    Set wkbAll = ActiveWorkbook
    wkbTemp.Close (False)
    wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
      Destination:=Range("A1"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, _
      ConsecutiveDelimiter:=False, _
      Tab:=False, Semicolon:=False, _
      Comma:=False, Space:=False, _
      Other:=True, OtherChar:="|"
    x = x + 1

    While x 

این ماکرو به شما امکان می دهد فایل هایی را که می خواهید وارد کنید انتخاب کنید و سپس داده های آن فایل ها را در کاربرگ های جداگانه در ورک بوک قرار می دهد. ماکرو فرض می کند که داده های وارد شده از کاراکتر لوله (|) به عنوان جداکننده بین فیلدها استفاده می کند.

اگر می دانید که فایل هایی که قرار است وارد شوند همیشه در یک پوشه خاص هستند و می خواهید همه فایل های آن پوشه را وارد کنید، می توانید ماکرو را کمی ساده کنید. مثال زیر فرض می کند که فایل ها در پوشه c: empload_excel هستند، اما شما می توانید با ایجاد یک تغییر ساده به متغیر fpath در کد ماکرو، نام پوشه را تغییر دهید.

Sub LoadPipeDelimitedFiles()
    Dim idx As Integer
    Dim fpath As String
    Dim fname As String

    idx = 0
    fpath = "c:	empload_excel"
    fname = Dir(fpath & "*.txt")
    While (Len(fname) > 0)
        idx = idx + 1
        Sheets("Sheet" & idx).Select
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" _
          & fpath & fname, Destination:=Range("A1"))
            .Name = "a" & idx
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileOtherDelimiter = "|"
            .TextFileColumnDataTypes = Array(1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
            fname = Dir
        End With
    Wend
End Sub