2

EXCEL 2010以下に、非常にうまく機能する記述されたマクロを示しますが、処理は1 x 1のみです。元のファイルには特定の拡張子があり、Excelで開いてから、以下のコードを実行します。保存は元の名前を維持して行う必要がありますが、拡張子は.xlsmのみになります。他のフォルダへの保存は現在機能していますが、現時点では名前を維持していません。ほぼ同じ質問をする人もいますが、まだ正しい答えは見つかりませんでした。すべてのファイル.extまたは.FUGフォルダーAを（Excelで）開き、マクロを処理し、元の名前を維持してフォルダー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 に答える