[發問] 如何匯入多個資料夾文字檔內容 匯入多個資料夾文字檔

luke

小弟最近剛學VBA,
我想從指定目錄D:\TEST, 按下" 匯入"按鈕,
自動取出資料夾裡的文字檔(*.ccc)第一列內容, 複製放入test.xls中的Sheets("IN"), 由G2開始依次匯入資料.

以下是我用巨集錄製方式只錄4個資料夾  
麻煩請教先進!!

Sub Macro1()
'
' Macro1 Macro
'
' 快速鍵: Ctrl+k
'
    Sheets("Sheet1").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\TEST\TT_00011111\00011112.ccc", Destination:=Range("$A$1"))
        .Name = "00011112"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 2)
        .TextFileFixedColumnWidths = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Selection.Copy
    Sheets("IN").Select
    Range("G2").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\TEST\TT_00012345\12345678.ccc", Destination:=Range("$A$1"))
        .Name = "12345678"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 2)
        .TextFileFixedColumnWidths = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Selection.Copy
    Sheets("IN").Select
    Range("G3").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\TEST\TT_00022222\00333333.ccc", Destination:=Range("$A$1"))
        .Name = "00333333"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 2)
        .TextFileFixedColumnWidths = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Selection.Copy
    Sheets("IN").Select
    Range("G4").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\TEST\TT_00023456\25153654.ccc", Destination:=Range("$A$1"))
        .Name = "25153654"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 2)
        .TextFileFixedColumnWidths = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Selection.Copy
    Sheets("IN").Select
    Range("G5").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Cells.Select
    Selection.QueryTable.Delete
    Selection.QueryTable.Delete
    Selection.QueryTable.Delete
    Selection.QueryTable.Delete
    Selection.ClearContents
    Sheets("IN").Select
    Range("A1").Select
End Sub

Hsieh

回復 1# luke

1. Sub 匯入()
   
2. Dim ary() As String, rw As Long, Mystr$, MyPath$
   
3. rw = 2: i = 0
   
4. path1 = "D:\TEST\"
   
5. file1 = Dir(path1 & "*.*", vbDirectory) '只處理資料夾
   
6. Do While file1 <> ""
   
7.   If file1 <> "." And file1 <> ".." And _
   
8.      GetAttr(path1 & file1) = vbDirectory Then
   
9.      i = i + 1
   
10.      ReDim Preserve ary(i)
    
11.      ary(i) = file1
    
12.   End If
    
13.   file1 = Dir
    
14. Loop
    
15. For i = 1 To UBound(ary)
    
16.    Cells(rw, 1) = ary(i)
    
17.    MyPath = path1 & ary(i) & "\"
    
18.    fs = Dir(MyPath & "*.ccc")
    
19.    Open MyPath & fs For Input As #1
    
20.    Line Input #1, Mystr
    
21.    Cells(rw, 7) = Mid(Mystr, 2)
    
22.    Close #1
    
23.    rw = rw + 1
    
24. Next i
    
25. End Sub

複製代碼