[發問] 請問如何更改VB的連結檔案路徑

這個VBA功能是將多個TXT內容全部會集到同一個EXCEL中
但是這程式必須跟TXT在同一個目錄
我試著修改成把程式放在C:\指定匯集D:\中的TXT
可是都沒成功
請問要怎麼修改才OK??
謝謝

Sub 匯入文字檔()
Dim xFile, uFile, uHead As Range, Jm&, Km&, X, xT, xL
Range("A:A").Clear '清除舊匯入資料
'-----------------------------------------------------
Application.ScreenUpdating = False
Do
If xChk = 0 Then
   xFile = Dir(ThisWorkbook.Path & "\*.txt")
   If xFile = "" Then MsgBox "※找不到 TXT 檔案！　", 0 + 16: Exit Sub
   xChk = 1
Else
   xFile = Dir
   If xFile = "" Then Exit Do
End If
'----------------------------------------------
uFile = ThisWorkbook.Path & "\" & xFile
Set uHead = Range("A65536").End(xlUp)
If uHead <> "" Then Set uHead = uHead(3, 1)
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & uFile, Destination:=uHead)
      .AdjustColumnWidth = False
      .TextFileColumnDataTypes = Array(1)
      .Refresh BackgroundQuery:=False
      .Delete
End With
uHead.Interior.ColorIndex = 6
'每筆第一格加〔黃色〕底
NEXT_LINE:
Loop
'-------------------------------------------------------
Application.ScreenUpdating = True
MsgBox "～～匯入完成～～　"
End Sub

匯入文字檔.zip (8.72 KB)

樓主熱帖

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 267
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2025-10-31

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2011-12-27 08:43 | 只看該作者

回復 1# v60i
用資料夾對話方塊結果取代ThisWorkbook.Path

Sub 匯入文字檔()
Dim xFile, uFile, uHead As Range, Jm&, Km&, X, xT, xL
Range("A:A").Clear '清除舊匯入資料
'-----------------------------------------------------
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fd = .SelectedItems(1)
End With
Application.ScreenUpdating = False
Do
If xChk = 0 Then
xFile = Dir(fd & "\*.txt")
If xFile = "" Then MsgBox "※找不到 TXT 檔案！　", 0 + 16: Exit Sub
xChk = 1
Else
xFile = Dir
If xFile = "" Then Exit Do
End If
'----------------------------------------------
uFile = fd & "\" & xFile
Set uHead = Range("A65536").End(xlUp)
If uHead <> "" Then Set uHead = uHead(3, 1)
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & uFile, Destination:=uHead)
.AdjustColumnWidth = False
.TextFileColumnDataTypes = Array(1)
.Refresh BackgroundQuery:=False
.Delete
End With
uHead.Interior.ColorIndex = 6
'每筆第一格加〔黃色〕底
NEXT_LINE:
Loop
'-------------------------------------------------------
Application.ScreenUpdating = True
MsgBox "～～匯入完成～～　"
End Sub