Vba 展开宏以选择全部"；txt"；处理后，将文件夹A中的文件另存为其他文件夹B中同名的文件

EXCEL 2010 在下面，您可以找到一个编写的宏，它工作得非常好，但它只能处理1乘1。 原始文件有一个特定的扩展名，希望用Excel打开它们，然后执行下面的代码。虽然保存时应保留原始名称，但只有扩展名为.xlsm。正在将文件保存到其他文件夹，但暂时不保留该名称。我看到有些人问了几乎相同的问题，但我还没有找到正确的答案。 我正在搜索（使用excel）打开.ext或.FUG文件夹A的所有文件，处理宏，另存为文件夹B，并保留原始名称，但扩展名为.xlsm 有没有办法简化宏

Sub tekst_naar_kolom()
'
' tekst_naar_kolom Macro
'
' Sneltoets: Ctrl+x
'
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 3), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), DecimalSeparator:= _
        ".", TrailingMinusNumbers:=True
    Cells.Select
    Cells.EntireColumn.AutoFit
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A4").Select
    ActiveWindow.FreezePanes = True
    ChDir _
        "D:\destinationfolder"
    ActiveWorkbook.SaveAs Filename:= _
        "D:\destinationfolder\**save file with same name**.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub

---

我建议使用Windows脚本主机FileSystemObject，下面的代码后期绑定此对象并遍历源文件夹的文件集合。当它发现一个以.ext或.FUG结尾的文件时，它会对其进行处理，并将其作为.xlsm文件保存在目标文件夹中。
只需调整源文件夹和目标文件夹并运行它-无论此代码位于哪个工作簿中，都不会更改，它会单独打开和保存文件，并在处理过程中保持此工作簿打开

Sub tekst_naar_kolom()
    Dim FSO As Object
    Dim oFile As Object
    Dim sSourcePath, sDestinationPath As String
    Dim sFileName, sNewFileName As String
    Dim wbProcess As Workbook

    'set source and destination folders
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sSourcePath = "C:\sourceFolder\"
    sDestinationPath = "C:\destinationFolder\"

    For Each oFile In FSO.GetFolder(sSourcePath).Files
        'if the current file ends with .ext or .FUG process it
        If LCase(Mid(oFile.Name, InStrRev(oFile.Name, "."))) = ".ext" Or _
                LCase(Mid(oFile.Name, InStrRev(oFile.Name, "."))) = ".guh" Or _
                LCase(Mid(oFile.Name, InStrRev(oFile.Name, "."))) = ".fug" Then
            'create the new file name & path
            sNewFileName = Left(oFile.Name, InStrRev(oFile.Name, ".") - 1)
            sNewFileName = sDestinationPath & sNewFileName & ".xlsm"

            'if the same file exists in the destination folder, do not process it
            If Not FSO.FileExists(sNewFileName) Then
                'use WorkBooks.OpenText to interpret the file
                Workbooks.OpenText oFile.Path, DataType:=xlDelimited, _
                    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                    Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                    :=Array(Array(1, 3), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), DecimalSeparator:= _
                    ".", TrailingMinusNumbers:=True
                Set wbProcess = ActiveWorkbook
                wbProcess.Sheets(1).Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                    Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
                    :=Array(Array(1, 3), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1)), DecimalSeparator:= _
                    ".", TrailingMinusNumbers:=True

                'autofit all columns, format
                wbProcess.Sheets(1).Cells.Select
                wbProcess.Sheets(1).Cells.EntireColumn.AutoFit
                With wbProcess.Sheets(1).Cells
                    .HorizontalAlignment = xlRight
                    .VerticalAlignment = xlBottom
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = False
                End With
                'freeze panes
                wbProcess.Sheets(1).Range("A4").Select
                wbProcess.Windows(1).FreezePanes = True

                'save in new folder with new file name
                wbProcess.SaveAs Filename:=sNewFileName _
                    , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                'reset variable for next file
                wbProcess.Close False
                Set wbProcess = Nothing
            End If
        End If
    Next oFile
End Sub

---

如何打开.ext文件？使用宏（如果是，请提供一些代码）还是手动？当.ext文件被导入到任何活动（！）工作簿的一列时，您从上面的宏开始是对的吗？谢谢您的反应！嗯，现在我必须用excel（原始的其他扩展名）打开文件，然后我必须复制其中的宏。然后，当我运行此代码时，它将选择列/maje写入的更改/将文件保存为.xlsm文件。我应该从另一个工作簿中执行此操作。因此，我有一个工作簿，其中我已经安装了一个对象按钮，在该命令上，代码也必须转到特定文件夹中查看/打开文件/进行更改”，但“它必须另存为文件的“first sheetname”或“与原始文件相同”（但扩展名为.xlsm）嗨，麦康尼先生，你给我的东西让我很兴奋！我看到代码有效地保存在正确的扩展名中，但由于某些原因，tekst到Colum的过程没有在xlsm文件中处理。我还注意到它没有保存在目标文件夹中，而是保存在它旁边。最后一部分也许我搞错了什么。我来检查一下。现在，谢谢你的这种奇妙的想法！！似乎正在制作tekst到COLUN（在屏幕上可见），但是当xlsm文件关闭时，它不会保存进程。该代码在我的测试文件上运行得非常好，这些文件是用分号分隔的简单文本文件。首先，确保在源文件夹和目标文件夹路径的末尾有一个反斜杠（）。如果你不能让它工作，也许你可以发布一些示例文件，显示原始文件的样子以及处理后的文件应该是什么。反斜杠问题已解决。放弃1。我是否有办法将需要格式化的原始文件发送给您？似乎我找不到上传文件的方法。好的，我刚刚更新了上面的代码-我将TextToColumns解析添加回了流程中。示例文件实际上没有分号分隔，但每行都是。我希望这能奏效。此外，您发布的文件的文件扩展名是.guh，请确保通过复制行

LCase（Mid（oFile.Name，InStrRev（oFile.Name，“.”））=“.guh”或