Question

我下面有两个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

Answer 1

要处理另一个文件夹，只需询问用户是否要再次运行代码。

Application.ScreenUpdating = True

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

通过VBA改进合并txt代码

1 个答案: