2

EXCEL 2010 您可以在下面找到一个运行良好的书面宏，但它只能逐个处理。原始文件有一个特定的扩展名，想用 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
4

1 回答 1

1

我建议使用 Windows Scripting Host FileSystemObject，后面的代码会绑定这个对象并遍历源文件夹的文件集合。当它找到以 .ext 或 .FUG 结尾的文件时，它会对其进行处理并将其作为 .xlsm 文件保存在目标文件夹中。
只需调整 Source 和 Destination 文件夹并运行它 - 无论此代码所在的任何工作簿都不会更改，它会单独打开并保存文件，在处理过程中使该工作簿保持打开状态。

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
于 2013-03-09T21:15:45.697 回答