返回列表 上一主題 發帖

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

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-3-28 22:24 | 顯示全部帖子

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

匯入多個資料夾文字檔
小弟最近剛學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

TEST.rar (26.44 KB)

TEST.rar (26.04 KB)

收藏 分享

        靜思自在 : 道德是提昇自我的明燈，不該是呵斥別人的鞭子。
返回列表 上一主題