Note: The other languages of the website are Google-translated. Back to English

如何將一個文件夾中的多個文本文件導入一個工作表?

例如,這裡有一個包含多個文本文件的文件夾,您要做的就是將這些文本文件導入到一個工作表中,如屏幕截圖所示。 有沒有什麼技巧可以將文本文件從一個文件夾快速導入到一張紙中,而不是一個一個地複製文本文件?

使用VBA將多個文本文件從一個文件夾導入到一張工作表中

使用Kutools for Excel將文本文件導入活動單元格 好主意3


這是一個VBA代碼,可以幫助您將所有文本文件從一個特定的文件夾導入到新的工作表中。

1.啟用要導入文本文件的工作簿,然後按 Alt + F11鍵 啟用鍵 Microsoft Visual Basic for Applications 窗口。

2。 點擊 插入 > 模塊,將下面的VBA代碼複製並粘貼到 模塊 窗口。

VBA:將多個文本文件從一個文件夾導入到一張工作表

Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

3。 按 F5 顯示對話框,然後選擇一個文件夾,其中包含要導入的文本文件。 看截圖:
doc從文件夾導入文本文件1

4。 點擊 OK。 然後,文本文件已作為新工作表分別導入到活動工作簿中。
doc從文件夾導入文本文件2


如果要將一個文本文件導入到特定的單元格或範圍,可以應用 Excel的Kutools在光標處插入文件 效用。

Excel的Kutools, 與以上 300 方便的功能,使您的工作更加輕鬆。 

免費安裝 Kutools for Excel,請執行以下操作:

1.選擇要導入文本文件的單元格,然後單擊 Kutools 加 > 進出口 > 在光標處插入文件。 看截圖:
doc從文件夾導入文本文件3

2.然後彈出一個對話框,單擊 瀏覽 顯示 選擇一個文件 插入單元格光標位置對話框中,然後選擇 文本文件 從下拉列表中,然後選擇要導入的文本文件。 看截圖:
doc從文件夾導入文本文件4

3。 點擊 已提交 > Ok,並且已在光標位置插入了指定文本文件,請參見屏幕截圖:
doc從文件夾導入文本文件5


最佳辦公效率工具

Kutools for Excel 解決了你的大部分問題,並將你的生產力提高了 80%

  • 重用: 快速插入 複雜的公式,圖表 以及您以前使用過的任何東西; 加密單元 帶密碼 創建郵件列表 並發送電子郵件...
  • 超級公式欄 (輕鬆編輯多行文本和公式); 閱讀版式 (輕鬆讀取和編輯大量單元格); 粘貼到過濾範圍...
  • 合併單元格/行/列 不會丟失數據; 拆分單元格內容; 合併重複的行/列...防止細胞重複; 比較範圍...
  • 選擇重複或唯一 行; 選擇空白行 (所有單元格都是空的); 超級查找和模糊查找 在許多工作簿中; 隨機選擇...
  • 確切的副本 多個單元格,無需更改公式參考; 自動創建參考 到多張紙; 插入項目符號,複選框等...
  • 提取文字,添加文本,按位置刪除, 刪除空間; 創建和打印分頁小計; 在單元格內容和註釋之間轉換...
  • 超級濾鏡 (將過濾方案保存並應用於其他工作表); 高級排序 按月/週/日,頻率及更多; 特殊過濾器 用粗體,斜體...
  • 結合工作簿和工作表; 根據關鍵列合併表; 將數據分割成多個工作表; 批量轉換xls,xlsx和PDF...
  • 超過 300 項強大的功能. 支持 Office / Excel 2007-2021 和 365。支持所有語言。 在您的企業或組織中輕鬆部署。 完整功能 30 天免費試用。 60 天退款保證。
kte選項卡201905

Office選項卡為Office帶來了選項卡式界面,使您的工作更加輕鬆

  • 在Word,Excel,PowerPoint中啟用選項卡式編輯和閱讀,發布者,Access,Visio和Project。
  • 在同一窗口的新選項卡中而不是在新窗口中打開並創建多個文檔。
  • 將您的工作效率提高 50%,每天為您減少數百次鼠標點擊!
officetab底部
按評論排序
留言 (46)
4中的5評分 · 1評級
網站主持人對此評論進行了最小化
子測試()
'更新通過Extendoffice6/7/2016
將 xWb 調暗為工作簿
將 xToBook 調暗為工作簿
將 xStrPath 調暗為字符串
將 xFileDialog 調暗為 FileDialog
將 xFile 調暗為字符串
將 xFiles 調暗為新集合
暗淡我只要
設置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "選擇一個文件夾 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那麼
xStrPath = xFileDialog.SelectedItems(1)
如果結束
如果 xStrPath = "" 則退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那麼
MsgBox "沒有找到文件", vbInformation, "Kutools for Excel"
退出小組
如果結束
執行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目錄()
循環
設置 xToBook = ThisWorkbook
如果 xFiles.Count > 0 那麼
對於 I = 1 到 xFiles.Count
設置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).複製之後:=xToBook.Sheets(xToBook.Sheets.Count)
在錯誤恢復下一頁
ActiveSheet.Name = xWb.Name
在錯誤轉到0
xWb.Close 錯誤
下一頁
如果結束
END SUB

這段代碼有幫助,但我想要

製表符,分號,空格 true 如何做到這一點請幫助我
網站主持人對此評論進行了最小化
將文本文件轉換為工作表後是否要保留空格(分隔符)?
網站主持人對此評論進行了最小化
這也是我的問題,這段代碼是真的。 但在將文本文件轉換為 excel 後,它不會保留分隔符。
網站主持人對此評論進行了最小化
你能上傳文本文件和你想要的結果嗎?
網站主持人對此評論進行了最小化
我也有同樣的問題。 txt 文件都在單獨的工作表中,代碼忽略了兩列之間的空格
網站主持人對此評論進行了最小化
你好,Des 和 PB Rama Murty,下面的代碼可以在將文本文件導入工作表時根據空格或製表符將數據拆分為列。 你可以試一試。

子 ImportTextToExcel()
'更新通過Extendoffice20180911
將 xWb 調暗為工作簿
將 xToBook 調暗為工作簿
將 xStrPath 調暗為字符串
將 xFileDialog 調暗為 FileDialog
將 xFile 調暗為字符串
將 xFiles 調暗為新集合
暗淡我只要
將 xIntRow 變暗
暗淡 xFNum, xFArr 只要
將 xStrValue 調暗為字符串
將 xRg 調暗為範圍
暗淡 xArr
設置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "選擇一個文件夾 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那麼
xStrPath = xFileDialog.SelectedItems(1)
如果結束
如果 xStrPath = "" 則退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那麼
MsgBox "沒有找到文件", vbInformation, "Kutools for Excel"
退出小組
如果結束
執行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目錄()
循環
設置 xToBook = ThisWorkbook
在錯誤恢復下一頁
Application.ScreenUpdating = False
如果 xFiles.Count > 0 那麼

對於 I = 1 到 xFiles.Count
設置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).複製之後:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close 錯誤
xIntRow = ActiveCell.CurrentRegion.Rows.Count
對於 xFNum = 1 到 xIntRow
設置 xRg = ActiveSheet.Range("A" & xFNum)
xArr = 拆分(xRg.Text,“”)
如果 UBound(xArr) > 0 那麼
對於 xFArr = 0 到 UBound(xArr)
如果 xArr(xFArr) <> "" 那麼
xRg.Value = xArr(xFArr)
設置 xRg = xRg.Offset(ColumnOffset:=1)
如果結束
下一頁
如果結束
下一頁
下一頁
如果結束
Application.ScreenUpdating = True
END SUB
網站主持人對此評論進行了最小化
如果要根據逗號將數據拆分為列,需要進行哪些更改
網站主持人對此評論進行了最小化
如果我需要根據逗號將數據放入列中,需要進行哪些更改?
網站主持人對此評論進行了最小化
我使用了它並且它有效,但我希望將它全部保存到一張紙上,因為每張紙都是相同的信息,它們只是每天的日誌文件。
所以我需要結合
文件夾中的所有項目到一張紙
子 ImportCSVsWithReference()
'更新由 KutoolsforExcel20151214
將 xWb 調暗為工作簿
將 xToBook 調暗為工作簿
將 xStrPath 調暗為字符串
將 xFileDialog 調暗為 FileDialog
將 xFile 調暗為字符串
將 xFiles 調暗為新集合
暗淡我只要
將 xIntRow 變暗
暗淡 xFNum, xFArr 只要
將 xStrValue 調暗為字符串
將 xRg 調暗為範圍
暗淡 xArr
出錯時轉到 ErrHandler
設置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "選擇一個文件夾 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那麼
xStrPath = xFileDialog.SelectedItems(1)
如果結束
如果 xStrPath = "" 則退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
設置 xSht = ThisWorkbook.ActiveSheet
If MsgBox("導入前清除現有工作表?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
執行 xFile <> ""
設置 xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close 錯誤
xFile = 目錄
循環
Application.ScreenUpdating = True
退出小組
錯誤處理程序:
MsgBox "沒有 txt 文件", , "Kutools for Excel"
END SUB

這個使用空格添加到每個列

子 ImportTextToExcel()
'更新通過Extendoffice20180911
將 xWb 調暗為工作簿
將 xToBook 調暗為工作簿
將 xStrPath 調暗為字符串
將 xFileDialog 調暗為 FileDialog
將 xFile 調暗為字符串
將 xFiles 調暗為新集合
暗淡我只要
將 xIntRow 變暗
暗淡 xFNum, xFArr 只要
將 xStrValue 調暗為字符串
將 xRg 調暗為範圍
暗淡 xArr
設置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "選擇一個文件夾 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那麼
xStrPath = xFileDialog.SelectedItems(1)
如果結束
如果 xStrPath = "" 則退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那麼
MsgBox "沒有找到文件", vbInformation, "Kutools for Excel"
退出小組
如果結束
執行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目錄()
循環
設置 xToBook = ThisWorkbook
在錯誤恢復下一頁
Application.ScreenUpdating = False
如果 xFiles.Count > 0 那麼

對於 I = 1 到 xFiles.Count
設置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).複製之後:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close 錯誤
xIntRow = ActiveCell.CurrentRegion.Rows.Count
對於 xFNum = 1 到 xIntRow
設置 xRg = ActiveSheet.Range("A" & xFNum)
xArr = 拆分(xRg.Text,“”)
如果 UBound(xArr) > 0 那麼
對於 xFArr = 0 到 UBound(xArr)
如果 xArr(xFArr) <> "" 那麼
xRg.Value = xArr(xFArr)
設置 xRg = xRg.Offset(ColumnOffset:=1)
如果結束
下一頁
如果結束
下一頁
下一頁
如果結束
Application.ScreenUpdating = True
END SUB
網站主持人對此評論進行了最小化
如果我的 Txt 文件包含使用逗號分隔的內容怎麼辦?
網站主持人對此評論進行了最小化
您可以先使用 Find and Replace 功能將逗號替換為空格,然後應用上述方法之一將其轉換為 Excel 文件。
網站主持人對此評論進行了最小化
沒有辦法在代碼中更改它嗎? 我必須用 130 個文件來做這個
網站主持人對此評論進行了最小化
同樣的問題
網站主持人對此評論進行了最小化
對於那些仍然需要幫助的人,請將 xArr = Split(xRg.Text, " ") 替換為 xArr = Split(xRg.Text, ",")。
網站主持人對此評論進行了最小化
當我按照給定的方式運行模塊時,它會將每個 .txt 文件添加為新工作表,而不是作為現有工作表的新行。 有沒有辦法將其作為輸出而不是每個 .txt 文件的新工作表來實現?
網站主持人對此評論進行了最小化
您的意思是將所有文本文件合併到一張紙上嗎?
網站主持人對此評論進行了最小化
是的,這也是我想要的。
網站主持人對此評論進行了最小化
嗨,Davinder,你可以試試下面的 vba 代碼。
Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
    Dim xSht  As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.txt")
    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
        xWb.Close False
        xFile = Dir
    Loop
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "no txt files", , "Kutools for Excel"
End Sub
網站主持人對此評論進行了最小化
該代碼非常有用,它是我發現的唯一可以批量獲取 txt 文件的代碼,我需要的修復也是 Joyce 和 Davinder 所追求的。
它是提取 .txt 文件並將它們全部粘貼到特定列中,比如說“N”列。

另外,需要知道是否可以為導入的 .txt 文件添加“if 條件”,如下所示。
如果 .txt 文件以字母“A”開頭,則粘貼在以單元格“N1”開頭的“工作表 2”上
如果 .txt 文件以字母“B”開頭,則粘貼在以單元格“N2”開頭的“Sheet 2”上
否則 MsgBox 為“無法識別的 .txt 文件用途”。

在此先謝謝
網站主持人對此評論進行了最小化
我有這段代碼對我有用,但我仍然需要在其中進行一些更改。

*我希望它粘貼在同一張紙上而不打開新紙然後復制它,因為它需要更長的時間。

*如果導入的txt文件以字母A開頭,則需要插入條件if粘貼到工作表1上,如果以字母B開頭,則導入到工作表2


子 testcopy3()
將 xWb 調暗為工作簿
將 xToBook 調暗為工作簿
將 xStrPath 調暗為字符串
將 xFileDialog 調暗為 FileDialog
將 xFile 調暗為字符串
將 xFiles 調暗為新集合
昏暗的我只要
將 LastRow 變暗
昏暗範圍
設置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "選擇一個文件夾 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那麼
xStrPath = xFileDialog.SelectedItems(1)
如果結束
如果 xStrPath = "" 則退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那麼
MsgBox "沒有找到文件", vbInformation, "Kutools for Excel"
退出小組
如果結束
執行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目錄()
循環
範圍(“N2”)。選擇
設置 xToBook = ThisWorkbook
如果 xFiles.Count > 0 那麼
對於 i = 1 到 xFiles.Count
設置 xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.激活
'選擇並複制txt數據
範圍(選擇,選擇。結束(xlDown))。選擇
Selection.Copy
xToBook.激活
ActiveSheet.Paste
選擇.結束(xlDown).偏移(1).選擇
在錯誤恢復下一頁
在錯誤轉到0
xWb.Close 錯誤
下一頁
如果結束
END SUB
網站主持人對此評論進行了最小化
對不起,我的手被綁住了
網站主持人對此評論進行了最小化
嗨,我的代碼運行但只導入第一個文件。 它說複製有一個方法錯誤。 調試器突出顯示以下代碼行。 有任何想法嗎?


xWb.Worksheets(1).複製之後:=xToBook.Sheets(xToBook.Sheets.Count)
網站主持人對此評論進行了最小化
我也遇到了同樣的問題,有找到解決辦法嗎?
網站主持人對此評論進行了最小化
嘿,凱蒂,
我知道您的評論已經很老了,但是我遇到了同樣的問題並以這種方式修復了它:該模塊必須插入到活動 .xlsx 項目的子文件夾中。 我錯誤地將代碼複製到我的 PERSONAL.XLSB 的子文件夾中,我通常在其中存儲我的宏,它與我的其他宏一起使用,但不是與這個宏。
網站主持人對此評論進行了最小化
如果您不想在重新執行模塊時重複,您將如何刪除 vba 代碼中的工作表?
網站主持人對此評論進行了最小化
抱歉,Harsh,請注意避免重複導入。
網站主持人對此評論進行了最小化
嗨,我想防止在 excel 中刪除前面的零。

我試過下面的代碼,但它不工作


子測試()
將 xWb 調暗為工作簿
將 xToBook 調暗為工作簿
將 xStrPath 調暗為字符串
將 xFileDialog 調暗為 FileDialog
將 xFile 調暗為字符串
將 xFiles 調暗為新集合
暗淡我只要
暗淡 j 只要
設置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "選擇一個文件夾"
如果 xFileDialog.Show = -1 那麼
xStrPath = xFileDialog.SelectedItems(1)
如果結束
如果 xStrPath = "" 則退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那麼
MsgBox "沒有找到文件", vbInformation, "Kutools for Excel"
退出小組
如果結束
執行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目錄()
循環
設置 xToBook = ThisWorkbook
如果 xFiles.Count > 0 那麼
對於 I = 1 到 xFiles.Count
設置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" '這是在粘貼文本文件數據之前將excel做成文本格式
xWb.Worksheets(1).複製之後:=xToBook.Sheets(xToBook.Sheets.Count)
在錯誤恢復下一頁
ActiveSheet.Name = xWb.Name
在錯誤轉到0
xWb.Close 錯誤
下一頁
如果結束
END SUB
網站主持人對此評論進行了最小化
Pooja,您可以嘗試 Kutools for Excel 的刪除前導零功能,以在導入後從選擇中刪除所有前導零。
查看附件 (1 / 5)
網站主持人對此評論進行了最小化
但我不想刪除。 我想防止刪除前面的零。
網站主持人對此評論進行了最小化
如果要保留前導零,可以通過 Cell Format 將它們格式化為文本格式。
網站主持人對此評論進行了最小化
您好,請問如何修改這段代碼插入*.txt文件的順序:1,2,3,4,5,6,7,8,9,10,11、1,10,11,12,13,14,15,16,17,18,19,2,20,21、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX、XNUMX等。目前代碼插入文件如下:XNUMX、 XNUMX 等。謝謝!
網站主持人對此評論進行了最小化
是否有機會僅從 txt 文件名中獲取工作表名稱的某些部分?

根據上面的代碼,整個工作表名稱一直在使用。
網站主持人對此評論進行了最小化
非常感謝 Office 2007 excel 上的工作
網站主持人對此評論進行了最小化
嗨,我的代碼運行但只導入第一個文件。 它說複製有一個方法錯誤。 調試器突出顯示以下代碼行。 有任何想法嗎?


xWb.Worksheets(1).複製之後:=xToBook.Sheets(xToBook.Sheets.Count)
網站主持人對此評論進行了最小化
嘿馬蒂尼奧,
我遇到了同樣的問題並通過更改此行來解決它:
設置 xToBook = ThisWorkbook

設置 xToBook = ActiveWorkbook
也許這有幫助。
網站主持人對此評論進行了最小化
0

我需要你的幫助我不知道 vba excel 我想導入多個文本文件,例如 13000。文本文件名與單元格相同,例如(c1=112 所以文本文件名也是 112)意味著文本文件 112 是進口c112。
網站主持人對此評論進行了最小化
我需要你的幫助我不知道 vba excel 我想導入多個文本文件,例如 13000。文本文件名與單元格相同,例如(c1=112 所以文本文件名也是 112)意味著文本文件 112 是進口c112。
網站主持人對此評論進行了最小化
該代碼有效,但將每個文本文件導入工作簿中的新選項卡。 知道在代碼中的哪個位置可以更改以在上一個文本文件的數據下方的同一工作表上導入新的文本文件嗎?
網站主持人對此評論進行了最小化
在下面的代碼中,如果我想指定文件夾而不是每次導入文本文件時都選擇路徑,則必須進行哪些修改

VBA代碼:

子 ImportCSVsWithReference()
'更新由 KutoolsforExcel20151214
將 xSht 調暗為工作表
將 xWb 調暗為工作簿
將 xStrPath 調暗為字符串
將 xFileDialog 調暗為 FileDialog
將 xFile 調暗為字符串
出錯時轉到 ErrHandler
設置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "選擇一個文件夾 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那麼
xStrPath = xFileDialog.SelectedItems(1)
如果結束
如果 xStrPath = "" 則退出 Sub
設置 xSht = ThisWorkbook.ActiveSheet
If MsgBox("導入前清除現有工作表?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.txt")
執行 xFile <> ""
設置 xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close 錯誤
xFile = 目錄
循環
Application.ScreenUpdating = True
退出小組
錯誤處理程序:
MsgBox "沒有 txt 文件", , "Kutools for Excel"
END SUB
網站主持人對此評論進行了最小化
你好,試試下面的代碼
Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    xStrPath = "C:\Users\AddinsVM001\Desktop\test" 'Here is the parth you can modify
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

“C:\Users\AddinsVM001\Desktop\test”是您可以從中導入文本文件的文件夾路徑,請根據需要進行更改。
網站主持人對此評論進行了最小化
您好,感謝您提供寶貴的 VBA 代碼。
但是,我需要將多個 txt 文件的代碼轉換為“工作表中的單個工作表,而不是每個 txt 文件的單個工作表”。
為了我的目的,我應該如何編輯您的代碼?

謝謝,
網站主持人對此評論進行了最小化
你好,試試下面的代碼
Sub Test()
    'UpdatebyExtendoffice 10/26/2022
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    Dim xSaveRg As Range
    Dim xSh As Worksheet
    
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    Set xSh = xToBook.Sheets.Add
    Set xRg = xSh.Range("A1")
    J = 1
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            Set xSaveRg = xWb.Worksheets(1).UsedRange
            J = xSaveRg.Rows.Count + 1 + J
            Debug.Print xRg.Address
            xSaveRg.Copy Destination:=xRg
            On Error Resume Next
            xWb.Close False
            
            Set xRg = xSh.Cells(J, 1)
        Next
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
網站主持人對此評論進行了最小化
這很好用。 但是當它導入時它用 name.txt 重命名工作表如何讓它只保留名稱而不向工作表添加 .txt 擴展名?
3.5中的5評分
網站主持人對此評論進行了最小化
好的 nvm 在谷歌幫助下找到了答案。
替換行:
ActiveSheet.Name = xWb.Name
使用:
ActiveSheet.Name = Left(xWb.Name,Len(xWb.Name)-4)
將從工作表名稱中刪除最後 4 個字母。 有效地給了我我需要的東西。 不帶 .txt 的名稱
乾杯
4中的5評分
網站主持人對此評論進行了最小化
在將文本文件導入工作表時,以下代碼可以根據空格或製表符將數據拆分為列。 但我不希望每個 txt 文件都有一個單獨的選項卡,我希望它們都在一張紙下。 每個文件的信息格式相同。 . 可以修改什麼以允許這全部是一張紙而不是每個導入的文件都是一個新選項卡任何和所有幫助將不勝感激

子 ImportTextToExcel()
'更新通過Extendoffice20180911
將 xWb 調暗為工作簿
將 xToBook 調暗為工作簿
將 xStrPath 調暗為字符串
將 xFileDialog 調暗為 FileDialog
將 xFile 調暗為字符串
將 xFiles 調暗為新集合
暗淡我只要
將 xIntRow 變暗
暗淡 xFNum, xFArr 只要
將 xStrValue 調暗為字符串
將 xRg 調暗為範圍
暗淡 xArr
設置 xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = 假
xFileDialog.Title = "選擇一個文件夾 [Kutools for Excel]"
如果 xFileDialog.Show = -1 那麼
xStrPath = xFileDialog.SelectedItems(1)
如果結束
如果 xStrPath = "" 則退出 Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
如果 xFile = "" 那麼
MsgBox "沒有找到文件", vbInformation, "Kutools for Excel"
退出小組
如果結束
執行 xFile <> ""
xFiles.Add xFile, xFile
xFile = 目錄()
循環
設置 xToBook = ThisWorkbook
在錯誤恢復下一頁
Application.ScreenUpdating = False
如果 xFiles.Count > 0 那麼

對於 I = 1 到 xFiles.Count
設置 xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).複製之後:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Close 錯誤
xIntRow = ActiveCell.CurrentRegion.Rows.Count
對於 xFNum = 1 到 xIntRow
設置 xRg = ActiveSheet.Range("A" & xFNum)
xArr = 拆分(xRg.Text,“”)
如果 UBound(xArr) > 0 那麼
對於 xFArr = 0 到 UBound(xArr)
如果 xArr(xFArr) <> "" 那麼
xRg.Value = xArr(xFArr)
設置 xRg = xRg.Offset(ColumnOffset:=1)
如果結束
下一頁
如果結束
下一頁
下一頁
如果結束
Application.ScreenUpdating = True
END SUB
網站主持人對此評論進行了最小化
嗨,丹尼爾,試試下面的代碼,它將所有文本文件導入一個名為 Txt 的工作表中。
注意:如果文本名稱與現有工作表名稱相同,則可能無法導入文本文件。
Sub ImportTextToExcel2()

'UpdatebyExtendoffice20230106

Dim xWb As Workbook

Dim xToBook As Workbook

Dim xStrPath As String

Dim xFileDialog As FileDialog

Dim xFile As String

Dim xFiles As New Collection

Dim I As Long

Dim xIntRow As Long

Dim xFNum, xFArr As Long

Dim xStrValue As String

Dim xRg As Range

Dim xArr

Dim xRowL, xRowH As Integer

Dim xTxtWS, xWSD As Worksheet

Dim xTxtWS_Rg As Range

Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

xFileDialog.AllowMultiSelect = False

xFileDialog.Title = "Select a folder [Kutools for Excel]"

If xFileDialog.Show = -1 Then

xStrPath = xFileDialog.SelectedItems(1)

End If

If xStrPath = "" Then Exit Sub

If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"

xFile = Dir(xStrPath & "*.txt")

If xFile = "" Then

MsgBox "No files found", vbInformation, "Kutools for Excel"

Exit Sub

End If

Do While xFile <> ""

xFiles.Add xFile, xFile

xFile = Dir()

Loop

Set xToBook = ThisWorkbook

On Error Resume Next

Set xTxtWS = xToBook.Worksheets("Txt")

If IsNull(xTxtWS) Or IsEmpty(xTxtWS) Then

    Set xTxtWS = xToBook.Worksheets.Add

    xTxtWS.Name = "Txt"

End If

Application.ScreenUpdating = False

Application.DisplayAlerts = False

xTxtWS.Activate

If xFiles.Count > 0 Then

xRowL = 1

For I = 1 To xFiles.Count

Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))

xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

Set xWSD = xToBook.Sheets(xToBook.Sheets.Count)

xTxtWS.Activate

xWb.Close False

xIntRow = xWSD.UsedRange.CurrentRegion.Rows.Count

    For xFNum = 1 To xIntRow

        Set xRg = xWSD.Range("A" & xFNum)

        xArr = Split(xRg.Text, " ")

        Set xTxtWS_Rg = xTxtWS.Cells.Range("A" & xRowL)

'        If UBound(xArr) > 0 Then

            For xFArr = 0 To UBound(xArr)

                If xArr(xFArr) <> "" Then

                xTxtWS_Rg.Value = xArr(xFArr)

                Set xTxtWS_Rg = xTxtWS_Rg.Offset(ColumnOffset:=1)

                End If

            Next

'        End If

xRowL = xRowL + 1

    Next

xWSD.Delete

Next

End If

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub


這裡還沒有評論
留下你的意見
以訪客身份發帖
×
評價此帖子:
0   字符
推薦地點

關注我們

版權所有©2009 - 萬維網。extendoffice.com。 | 版權所有。 供電 ExtendOffice。 |
Microsoft和Office徽標是Microsoft Corporation在美國和/或其他國家的商標或註冊商標。
受Sectigo SSL保護