💨

エクセルマクロ

2023/11/30に公開18件

エクセルマクロ

Sub ConvertFilesToText()
Dim folderPath As String, outputPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力先フォルダの作成
outputPath = folderPath & "\text_extract_result"
If Not FileSystem.Dir(outputPath, vbDirectory) <> "" Then
    MkDir outputPath
End If

' 指定されたパス内のファイルを検索し、変換
Call ProcessFilesInFolder(folderPath, "", outputPath)

End Sub

Sub ProcessFilesInFolder(folderPath As String, prefix As String, outputPath As String)
Dim fileName As String
fileName = Dir(folderPath & "*.*")

Do While fileName <> ""
    If Right(fileName, 5) = ".xlsm" Or Right(fileName, 4) = ".xls" Or Right(fileName, 4) = ".log" Or Right(fileName, 4) = ".xml" Then
        Call ConvertFileToText(folderPath, fileName, prefix, outputPath)
    End If
    fileName = Dir()
Loop

Dim subFolderName As String
subFolderName = Dir(folderPath & "\", vbDirectory)

Do While subFolderName <> ""
    If subFolderName <> "." And subFolderName <> ".." Then
        If (GetAttr(folderPath & "\" & subFolderName) And vbDirectory) = vbDirectory Then
            Call ProcessFilesInFolder(folderPath & "\" & subFolderName, prefix & subFolderName & "_", outputPath)
        End If
    End If
    subFolderName = Dir()
Loop

End Sub

Sub ConvertFileToText(folderPath As String, fileName As String, prefix As String, outputPath As String)
If Right(fileName, 4) = ".xls" Or Right(fileName, 5) = ".xlsm" Then
Call ConvertExcelToText(folderPath & "" & fileName, prefix, outputPath)
Else
FileCopy folderPath & "" & fileName, outputPath & "" & prefix & fileName & ".txt"
End If
End Sub

Sub ConvertExcelToText(filePath As String, prefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks.Open(filePath)

For Each ws In wb.Sheets
    ws.SaveAs Filename:=outputPath & "\" & prefix & Replace(Replace(filePath, wb.Path & "\", ""), ".xls", "_" & ws.Name & ".txt"), FileFormat:=xlText
Next ws

wb.Close False

End Sub

Discussion

akiyamah006 5ヶ月前

Sub ProcessFilesInFolder(folderPath As String, prefix As String, outputPath As String)
Dim fso As Object, folder As Object, subfolder As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

' ファイルの処理
For Each file In folder.Files
    Dim fileName As String
    fileName = file.Name
    If Right(fileName, 5) = ".xlsm" Or Right(fileName, 4) = ".xls" Or Right(fileName, 4) = ".log" Or Right(fileName, 4) = ".xml" Then
        Call ConvertFileToText(folderPath, fileName, prefix, outputPath)
    End If
Next file

' サブフォルダの処理
For Each subfolder In folder.SubFolders
    Call ProcessFilesInFolder(subfolder.Path, prefix & subfolder.Name & "_", outputPath)
Next subfolder

End Sub

akiyamah006 5ヶ月前

'''
Sub ConvertFilesToText()
Dim folderPath As String, outputPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力先フォルダの作成
outputPath = folderPath & "\text_extract_result"
If Not FileSystem.Dir(outputPath, vbDirectory) <> "" Then
    MkDir outputPath
End If

' ファイル一覧の取得と処理
ProcessFiles folderPath, outputPath

End Sub

Sub ProcessFiles(folderPath As String, outputPath As String)
Dim fso As Object, folder As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

For Each file In folder.Files
    Dim fileName As String
    fileName = file.Name
    If Right(fileName, 5) = ".xlsm" Or Right(fileName, 4) = ".xls" Then
        ' Excelファイルの処理
        ConvertExcelToText file.Path, outputPath
    ElseIf Right(fileName, 4) = ".log" Or Right(fileName, 4) = ".xml" Then
        ' ログファイルまたはXMLファイルの処理
        FileCopy file.Path, outputPath & "\" & Replace(file.Path, folderPath & "\", "") & ".txt"
    End If
Next file

End Sub

Sub ConvertExcelToText(filePath As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks.Open(filePath)

For Each ws In wb.Sheets
    ws.SaveAs Filename:=outputPath & "\" & Replace(Replace(filePath, wb.Path & "\", ""), ".xls", "_" & ws.Name & ".txt"), FileFormat:=xlText
Next ws

wb.Close False

End Sub

'''

akiyamah006 5ヶ月前

Sub ConvertFilesToText()
Dim folderPath As String, outputPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力先フォルダの作成
outputPath = folderPath & "\text_extract_result"
If Not FileSystem.Dir(outputPath, vbDirectory) <> "" Then
    MkDir outputPath
End If

' 指定されたパス内のファイルを検索し、変換
ProcessFiles folderPath, "", outputPath

End Sub

Sub ProcessFiles(folderPath As String, prefix As String, outputPath As String)
Dim fso As Object, folder As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

For Each file In folder.Files
    Dim fileName As String
    fileName = file.Name
    If Right(fileName, 5) = ".xlsm" Or Right(fileName, 4) = ".xls" Then
        ' Excelファイルの処理
        ConvertExcelToText file.Path, prefix, outputPath
    ElseIf Right(fileName, 4) = ".log" Or Right(fileName, 4) = ".xml" Then
        ' ログファイルまたはXMLファイルの処理
        FileCopy file.Path, outputPath & "\" & prefix & fileName & ".txt"
    End If
Next file

For Each subfolder In folder.SubFolders
    ProcessFiles subfolder.Path, prefix & subfolder.Name & "_", outputPath
Next subfolder

End Sub

Sub ConvertExcelToText(filePath As String, prefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks.Open(filePath)

For Each ws In wb.Sheets
    ws.SaveAs Filename:=outputPath & "\" & prefix & Replace(Replace(filePath, wb.Path & "\", ""), ".xls", "_" & ws.Name & ".txt"), FileFormat:=xlText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertExcelToText(filePath As String, prefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String
Set wb = Workbooks.Open(filePath)

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    ' ファイル名から.xlsmまたは.xlsxの拡張子を取り除く
    txtFileName = outputPath & "\" & prefix & Replace(Replace(wb.Name, ".xlsx", ""), ".xlsm", "") & "_" & ws.Name & ".txt"

    ' ファイル名の長さを確認
    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストとしてシートを保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlTextWindows
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertExcelToText(filePath As String, prefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ワークブック名から拡張子を除去
baseFileName = Replace(wb.Name, ".xlsx", "")
baseFileName = Replace(baseFileName, ".xlsm", "")

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & prefix & baseFileName & "_" & ws.Name & ".txt"
    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertExcelToText(filePath As String, prefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ファイル名からワークブック名を取得し、拡張子を除去
baseFileName = wb.Name
baseFileName = Replace(baseFileName, ".xlsx", "")
baseFileName = Replace(baseFileName, ".xlsm", "")

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & prefix & baseFileName & "_" & ws.Name & ".txt"
    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更して保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertExcelToText(filePath As String, prefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ファイル名からワークブック名を取得し、拡張子を除去
baseFileName = wb.Name
If InStrRev(baseFileName, ".") > 0 Then
    baseFileName = Left(baseFileName, InStrRev(baseFileName, ".") - 1)
End If

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & prefix & baseFileName & "_" & ws.Name & ".txt"
    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更して保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertExcelToText(filePath As String, prefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ファイル名からワークブック名を取得し、拡張子を除去
baseFileName = wb.Name
baseFileName = Left(baseFileName, InStrRev(baseFileName, ".") - 1)

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & prefix & baseFileName & "_" & ws.Name & ".txt"
    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更して保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertExcelToText(filePath As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ワークブック名から拡張子を除去
baseFileName = wb.Name
baseFileName = Left(baseFileName, InStrRev(baseFileName, ".") - 1)

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & baseFileName & "_" & ws.Name & ".txt"

    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更して保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertFilesToText()
Dim folderPath As String, outputPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力先フォルダの作成
outputPath = folderPath & "\text_extract_result"
If Not FileSystem.Dir(outputPath, vbDirectory) <> "" Then
    MkDir outputPath
End If

' 指定されたパス内のファイルを検索し、変換
ProcessFiles folderPath, outputPath

End Sub

Sub ProcessFiles(folderPath As String, outputPath As String)
Dim fso As Object, folder As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

For Each file In folder.Files
    Dim fileName As String
    fileName = file.Name
    If Right(fileName, 5) = ".xlsm" Or Right(fileName, 4) = ".xls" Or Right(fileName, 4) = ".xlsx" Then
        ' Excelファイルの処理
        ConvertExcelToText file.Path, outputPath
    ElseIf Right(fileName, 4) = ".log" Or Right(fileName, 4) = ".xml" Then
        ' ログファイルまたはXMLファイルの処理
        FileCopy file.Path, outputPath & "\" & fileName & ".txt"
    End If
Next file

For Each subfolder In folder.SubFolders
    ProcessFiles subfolder.Path, outputPath
Next subfolder

End Sub

Sub ConvertExcelToText(filePath As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ワークブック名から拡張子を除去
baseFileName = wb.Name
baseFileName = Left(baseFileName, InStrRev(baseFileName, ".") - 1)

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & baseFileName & "_" & ws.Name & ".txt"

    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更して保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertFilesToText()
Dim folderPath As String, outputPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力先フォルダの作成
outputPath = folderPath & "\text_extract_result"
If Not FileSystem.Dir(outputPath, vbDirectory) <> "" Then
    MkDir outputPath
End If

' 指定されたパス内のファイルを検索し、変換
ProcessFiles folderPath, "", outputPath, folderPath

End Sub

Sub ProcessFiles(folderPath As String, folderPrefix As String, outputPath As String, rootPath As String)
Dim fso As Object, folder As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

For Each file In folder.Files
    Dim fileName As String
    fileName = file.Name
    If Right(fileName, 5) = ".xlsm" Or Right(fileName, 5) = ".xlsx" Then
        ' Excelファイルの処理
        ConvertExcelToText file.Path, folderPrefix, outputPath
    ElseIf Right(fileName, 4) = ".log" Or Right(fileName, 4) = ".xml" Then
        ' ログファイルまたはXMLファイルの処理
        FileCopy file.Path, outputPath & "\" & folderPrefix & fileName & ".txt"
    End If
Next file

For Each subfolder In folder.SubFolders
    Dim newPrefix As String
    newPrefix = folderPrefix & Replace(subfolder.Path, rootPath & "\", "") & "_"
    ProcessFiles subfolder.Path, newPrefix, outputPath, rootPath
Next subfolder

End Sub

Sub ConvertExcelToText(filePath As String, folderPrefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ワークブック名から拡張子を除去
baseFileName = wb.Name
baseFileName = Left(baseFileName, InStrRev(baseFileName, ".") - 1)

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & folderPrefix & baseFileName & "_" & ws.Name & ".txt"

    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更して保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertFilesToText()
Dim folderPath As String, outputPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力先フォルダの作成
outputPath = folderPath & "\text_extract_result"
If Not FileSystem.Dir(outputPath, vbDirectory) <> "" Then
    MkDir outputPath
End If

' 指定されたパス内のファイルを検索し、変換
ProcessFiles folderPath, "", outputPath

End Sub

Sub ProcessFiles(folderPath As String, folderPrefix As String, outputPath As String)
Dim fso As Object, folder As Object, file As Object, subfolder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

' ファイルの処理
For Each file In folder.Files
    Dim fileName As String
    fileName = file.Name
    If Right(fileName, 5) = ".xlsm" Or Right(fileName, 5) = ".xlsx" Then
        ' Excelファイルの処理
        ConvertExcelToText file.Path, folderPrefix, outputPath
    ElseIf Right(fileName, 4) = ".log" Or Right(fileName, 4) = ".xml" Then
        ' ログファイルまたはXMLファイルの処理
        FileCopy file.Path, outputPath & "\" & folderPrefix & fileName & ".txt"
    End If
Next file

' サブフォルダの処理
For Each subfolder In folder.SubFolders
    ProcessFiles subfolder.Path, folderPrefix & subfolder.Name & "_", outputPath
Next subfolder

End Sub

Sub ConvertExcelToText(filePath As String, folderPrefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ワークブック名から拡張子を除去
baseFileName = wb.Name
baseFileName = Left(baseFileName, InStrRev(baseFileName, ".") - 1)

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & folderPrefix & baseFileName & "_" & ws.Name & ".txt"

    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更して保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ConvertFilesToText()
Dim folderPath As String, outputPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください (/target)"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力先フォルダの作成 (/target/text_extract/)
outputPath = folderPath & "\text_extract"
If Not FileSystem.Dir(outputPath, vbDirectory) <> "" Then
    MkDir outputPath
End If

' 指定されたパス内のファイルを検索し、変換
ProcessFiles folderPath, "", outputPath, folderPath

End Sub

Sub ProcessFiles(folderPath As String, folderPrefix As String, outputPath As String, rootPath As String)
Dim fso As Object, folder As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

For Each file In folder.Files
    Dim fileName As String
    fileName = file.Name
    If Right(fileName, 5) = ".xlsm" Or Right(fileName, 5) = ".xlsx" Then
        ' Excelファイルの処理
        ConvertExcelToText file.Path, folderPrefix, outputPath
    ElseIf Right(fileName, 4) = ".log" Or Right(fileName, 4) = ".xml" Then
        ' ログファイルまたはXMLファイルの処理
        FileCopy file.Path, outputPath & "\" & folderPrefix & Replace(fileName, "\", "_") & ".txt"
    End If
Next file

For Each subfolder In folder.SubFolders
    Dim newPrefix As String
    newPrefix = folderPrefix & Replace(subfolder.Path, rootPath & "\", "") & "_"
    ProcessFiles subfolder.Path, newPrefix, outputPath, rootPath
Next subfolder

End Sub

Sub ConvertExcelToText(filePath As String, folderPrefix As String, outputPath As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String, baseFileName As String
Set wb = Workbooks.Open(filePath)

' ワークブック名から拡張子を除去
baseFileName = wb.Name
baseFileName = Left(baseFileName, InStrRev(baseFileName, ".") - 1)

For Each ws In wb.Sheets
    ' テキストファイル名の生成
    txtFileName = outputPath & "\" & folderPrefix & baseFileName & "_" & ws.Name & ".txt"

    If Len(txtFileName) > 255 Then
        MsgBox "ファイル名が長すぎます: " & txtFileName
        Exit Sub
    End If

    ' テキストフォーマットをxlUnicodeTextに変更して保存
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub WriteFileListToText()
Dim folderPath As String, outputPath As String, txtFilePath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力ファイルのパスを設定
txtFilePath = folderPath & "\tmp.txt"

' 指定されたパス内のファイル一覧を取得し、テキストファイルに書き出す
WriteFilesToFile folderPath, txtFilePath

End Sub

Sub WriteFilesToFile(folderPath As String, txtFilePath As String)
Dim fso As Object, folder As Object, file As Object, subfolder As Object
Dim txtStream As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)
Set txtStream = fso.CreateTextFile(txtFilePath, True)

' フォルダ内のファイルとサブフォルダを走査
For Each file In folder.Files
    txtStream.WriteLine file.Path
Next file
For Each subfolder In folder.SubFolders
    WriteFilesToSubFolder subfolder, txtStream
Next subfolder

txtStream.Close

End Sub

Sub WriteFilesToSubFolder(subfolder As Object, txtStream As Object)
Dim file As Object
For Each file In subfolder.Files
txtStream.WriteLine file.Path
Next file
For Each subfolder In subfolder.SubFolders
WriteFilesToSubFolder subfolder, txtStream
Next subfolder
End Sub

akiyamah006 5ヶ月前

Sub WriteFileListToText()
Dim folderPath As String, txtFilePath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力ファイルのパスを設定
txtFilePath = folderPath & "\tmp.txt"

' 指定されたパス内のファイル一覧を取得し、テキストファイルに書き出す
WriteFilesToFile folderPath, txtFilePath, folderPath

End Sub

Sub WriteFilesToFile(folderPath As String, txtFilePath As String, rootPath As String)
Dim fso As Object, folder As Object, txtStream As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)
Set txtStream = fso.CreateTextFile(txtFilePath, True)

' フォルダ内のファイルとサブフォルダを走査
WriteFilesToSubFolder folder, txtStream, rootPath

txtStream.Close

End Sub

Sub WriteFilesToSubFolder(folder As Object, txtStream As Object, rootPath As String)
Dim file As Object, subfolder As Object
For Each file In folder.Files
txtStream.WriteLine Replace(file.Path, rootPath & "", "")
Next file
For Each subfolder In folder.SubFolders
WriteFilesToSubFolder subfolder, txtStream, rootPath
Next subfolder
End Sub

akiyamah006 5ヶ月前

Sub ConvertFilesToText()
Dim folderPath As String, outputPath As String, txtFilePath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
folderPath = .SelectedItems(1)
End With

' 出力先フォルダの作成 (text_extractフォルダ)
outputPath = folderPath & "\text_extract"
If Not FileSystem.Dir(outputPath, vbDirectory) <> "" Then
    MkDir outputPath
End If

' ファイル一覧の取得と出力 (tmp.txtファイル)
txtFilePath = folderPath & "\tmp.txt"
WriteFilesToFile folderPath, txtFilePath, folderPath

' tmp.txtファイルから行を読み込み、各ファイルを処理
ProcessFilesFromList txtFilePath, folderPath, outputPath

End Sub

Sub WriteFilesToFile(folderPath As String, txtFilePath As String, rootPath As String)
Dim fso As Object, folder As Object, txtStream As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)
Set txtStream = fso.CreateTextFile(txtFilePath, True)

WriteFilesToSubFolder folder, txtStream, rootPath

txtStream.Close

End Sub

Sub WriteFilesToSubFolder(folder As Object, txtStream As Object, rootPath As String)
Dim file As Object, subfolder As Object
For Each file In folder.Files
txtStream.WriteLine Replace(file.Path, rootPath & "", "")
Next file
For Each subfolder In folder.SubFolders
WriteFilesToSubFolder subfolder, txtStream, rootPath
Next subfolder
End Sub

Sub ProcessFilesFromList(txtFilePath As String, rootPath As String, outputPath As String)
Dim fso As Object, txtStream As Object, line As String, fullFilePath As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set txtStream = fso.OpenTextFile(txtFilePath, ForReading)

Do While Not txtStream.AtEndOfStream
    line = txtStream.ReadLine
    fullFilePath = rootPath & "\" & line
    If fso.FileExists(fullFilePath) Then
        If Right(line, 5) = ".xlsm" Or Right(line, 5) = ".xlsx" Then
            ConvertExcelToText fullFilePath, outputPath, Replace(line, ".xlsx", "").Replace(".xlsm", "")
        ElseIf Right(line, 4) = ".log" Or Right(line, 4) = ".xml" Then
            FileCopy fullFilePath, outputPath & "\" & Replace(line, "\", "_") & ".txt"
        End If
    End If
Loop

txtStream.Close

End Sub

Sub ConvertExcelToText(filePath As String, outputPath As String, baseFileName As String)
Dim wb As Workbook, ws As Worksheet, txtFileName As String
Set wb = Workbooks.Open(filePath)

For Each ws In wb.Sheets
    txtFileName = outputPath & "\" & baseFileName & "_" & ws.Name & ".txt"
    ws.SaveAs Filename:=txtFileName, FileFormat:=xlUnicodeText
Next ws

wb.Close False

End Sub

akiyamah006 5ヶ月前

Sub ProcessFilesFromList(txtFilePath As String, rootPath As String, outputPath As String)
Dim fso As Object, txtStream As Object, line As String, fullFilePath As String
Dim baseFileName As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set txtStream = fso.OpenTextFile(txtFilePath, ForReading)

Do While Not txtStream.AtEndOfStream
    line = txtStream.ReadLine
    fullFilePath = rootPath & "\" & line

    If fso.FileExists(fullFilePath) Then
        baseFileName = line
        baseFileName = Replace(baseFileName, ".xlsx", "")
        baseFileName = Replace(baseFileName, ".xlsm", "")

        If Right(line, 5) = ".xlsm" Or Right(line, 5) = ".xlsx" Then
            ConvertExcelToText fullFilePath, outputPath, baseFileName
        ElseIf Right(line, 4) = ".log" Or Right(line, 4) = ".xml" Then
            FileCopy fullFilePath, outputPath & "\" & Replace(line, "\", "_") & ".txt"
        End If
    End If
Loop

txtStream.Close

End Sub

akiyamah006 5ヶ月前

Sub ProcessFilesFromList(txtFilePath As String, rootPath As String, outputPath As String)
Const ForReading = 1
Dim fso As Object, txtStream As Object, line As String, fullFilePath As String
Dim baseFileName As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set txtStream = fso.OpenTextFile(txtFilePath, ForReading)

Do While Not txtStream.AtEndOfStream
    line = txtStream.ReadLine
    fullFilePath = rootPath & "\" & line

    If fso.FileExists(fullFilePath) Then
        baseFileName = line
        baseFileName = Replace(baseFileName, ".xlsx", "")
        baseFileName = Replace(baseFileName, ".xlsm", "")

        If Right(line, 5) = ".xlsm" Or Right(line, 5) = ".xlsx" Then
            ConvertExcelToText fullFilePath, outputPath, baseFileName
        ElseIf Right(line, 4) = ".log" Or Right(line, 4) = ".xml" Then
            FileCopy fullFilePath, outputPath & "\" & Replace(line, "\", "_") & ".txt"
        End If
    End If
Loop

txtStream.Close

End Sub