时间戳

首页 > 解决方案 > 通过 VBA 改进组合 txt 代码

vba - 通过 VBA 改进组合 txt 代码

问题描述

我有以下分为两个的 VBA 代码。代码的第一部分从文件目录收集数据并将其粘贴到 excel 文件中（文件名、路径和修改日期）。

代码的第二部分收集文件夹中的所有 txt 文件并将它们标记到同一张表中的一个列表中。

我试图改进我的代码以支持多个文件夹源并将两个代码合并为一个（我将两个不同的代码合并为一个），但我没有做到。知道如何修改它吗？

谢谢，

代码：

Sub list()

'adding file name, path & last modify date

  Dim FSO As Scripting.FileSystemObject
    Dim FileItem As Scripting.File

    SourceFolderName = "\\HA04HUCM0002\TestLog\LOT\avi_tests"

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

    Range("c2:e2") = Array("text file", "path", "Date Last Modified")

    i = 3
    For Each FileItem In SourceFolder.Files
        Cells(i, 3) = FileItem.Name
        Cells(i, 4) = FileItem
        Cells(i, 5) = FileItem.DateLastModified
        i = i + 1
    Next FileItem

    Set FSO = Nothing
'combain txt data into one sheet
 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)
 Columns(1).Insert xlShiftToRight
 Columns(1).SpecialCells(xlBlanks).Value = ActiveSheet.Name
 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

标签： vbaexcel

解决方案

To process another folder, simply ask the User if they want to run the code again. 

Application.ScreenUpdating = True

If MsgBox("Do you want to process  another folder?", vbYesNoCancel, "Kutools for Excel") = vbYes Then
    Call list
End If

推荐阅读