Visual Basic for Applications(VBA)を使用して、業務を合理化するツールを開発し
Microsoft Officeで簡単に実行できるものを一部を公開しました。
このツールは誰でも自由にご利用いただけます。
もし「こんな機能があれば助かる」とお考えの場合は、遠慮なく直接ご連絡ください。
生成AIを用いて、短時間でシステム構築しておりますので、通常より10倍以上は安く承れます。(例)数千円
dop@dopnet.jp


フォルダー内のファイル名一覧を作成

    指定のフォルダー内の、ファイル名を
    ボタン一つで、ExcelのA列に一覧表示することが出来ます。
    フォルダー内にある複数のファイルをリスト化する場合(電子帳簿等)、便利です。


    無料ダウンロード
    フォルダー内のファイル名一覧を作成ツール
    ※Microsoft Excelを使用します。


    使用VBAコード----------
    Sub ListFiles()
    Dim FileSystem As Object
    Dim HostFolder As String

    ' エクセルのシート1のC5セルからフォルダパスを取得します。
    HostFolder = ThisWorkbook.Sheets(1).Range("C6").Value

    ' FileSystemObjectのインスタンスを作成
    Set FileSystem = CreateObject("Scripting.FileSystemObject")

    ' 指定されたフォルダ内のファイルを列挙
    Call ListFilesInFolder(FileSystem.GetFolder(HostFolder), True)

    ' オブジェクトを解放
    Set FileSystem = Nothing
    End Sub

    Sub ListFilesInFolder(ByRef Folder As Object, IncludeSubFolders As Boolean)
    Dim File As Object
    Dim r As Long

    ' 次の書き込み位置を取得
    r = ThisWorkbook.Sheets(1).Cells(ThisWorkbook.Sheets(1).Rows.Count, "A").End(xlUp).Row + 1

    ' フォルダ内の各ファイルに対してループ
    For Each File In Folder.Files
    ' A列にファイル名を書き込む
    ThisWorkbook.Sheets(1).Cells(r, 1).Value = File.Name
    r = r + 1 ' 次の行へ
    Next File

    ' IncludeSubFoldersがTrueの場合はサブフォルダも検索
    If IncludeSubFolders Then
    Dim SubFolder As Object
    For Each SubFolder In Folder.SubFolders
    Call ListFilesInFolder(SubFolder, True)
    Next SubFolder
    End If
    End Sub

フォルダー内の古いファイルを削除

    指定のフォルダー内の、古いファイルをまとめて削除します。
    経過日数を指定して、それ以上経過した古いファイルに関しては全て削除いたします。
    毎回、手作業でファイル削除をされている方には便利なツールになります。
    (注意)削除後に復元できませんので自己責任でご使用ください


    無料ダウンロード
    フォルダー内の古いファイルを削除
    ※Microsoft Excelを使用します。


    使用VBAコード----------
    Sub 古いファイルを削除する()
    ' 変数を宣言
    Dim basePath As String, extension As String
    Dim fileName As String
    Dim fileDate As Date
    Dim diffDay As Integer
    Dim specifiedDays As Variant ' 空白を許容するためにVariant型を使用
    Dim ws As Worksheet

    ' ワークシートを設定
    Set ws = ThisWorkbook.Sheets("Sheet1") ' "Sheet1"を実際のシート名に変更してください

    ' セルから値を取得
    specifiedDays = ws.Range("C5").Value ' Excelシートからの指定日数
    basePath = ws.Range("C11").Value ' Excelシートからのフォルダパス
    extension = "xdw" ' ファイルの拡張子を設定

    ' 指定日数が入力されているか確認
    If IsEmpty(specifiedDays) Then
    MsgBox "セルC5に指定日数を入力してください。", vbExclamation
    Exit Sub
    End If

    ' basePathが空でないことを確認
    If basePath <> "" Then
    ' 指定した拡張子を持つディレクトリ内の最初のファイルを取得
    fileName = Dir(basePath & "\*" & extension, vbNormal)

    ' ディレクトリ内のすべてのファイルをループ
    Do Until fileName = ""
    ' ファイルの最終変更日を取得
    fileDate = FileDateTime(basePath & "\" & fileName)

    ' 最終変更日から現在日までの日数の差を計算
    diffDay = DateDiff("d", fileDate, Now())

    ' 差が指定された日数より大きい場合、ファイルを削除
    If diffDay > specifiedDays Then
    Kill basePath & "\" & fileName
    End If

    ' ディレクトリ内の次のファイルを取得
    fileName = Dir()
    Loop
    Else
    MsgBox "セルC11に有効なフォルダパスを指定してください。", vbExclamation
    End If
    End Sub

フォルダー内の複数のファイルを容量を指定して圧縮

    指定のフォルダー内にある、複数のファイルから
    指定された容量(MB)以下の圧縮ファイルを複数自動作成します。
    写真等をFTPアップロードする際に、容量制限がある場合便利です。


    無料ダウンロード
    フォルダー内の複数のファイルを容量を指定して圧縮
    ※Microsoft Excelを使用します。
    ※Lhaplusを使用します


    使用VBAコード----------
    Sub CallLhaplusZip()
    Dim result As Boolean

    result = lhaplus_zip() ' Functionを実行して結果を取得

    If result Then
    MsgBox "圧縮が正常に完了しました。", vbInformation, "完了"
    Else
    MsgBox "圧縮に失敗しました。", vbCritical, "エラー"
    End If
    End Sub

    Function lhaplus_zip() As Boolean
    Dim fso As Object, WSH As Object
    Dim Cmd As String
    Dim FileName As String
    Dim targetFile() As String
    Dim i As Long, j As Long
    Dim targetPath As String
    Dim fileSize As Double
    Dim maxFileSizeMB As Double ' 最大ファイルサイズ(MB)
    Dim maxFileSizeBytes As Double ' 最大ファイルサイズ(バイト)

    ' フォルダパスと最大ファイルサイズをシートのC4、C5セルから取得
    targetPath = ThisWorkbook.Sheets("Sheet1").Range("C8").Value
    maxFileSizeMB = ThisWorkbook.Sheets("Sheet1").Range("C13").Value ' C5セルから最大ファイルサイズ(MB)を取得
    maxFileSizeBytes = maxFileSizeMB * 1024 * 1024 ' MBをバイトに変換

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set WSH = CreateObject("Wscript.Shell")

    ' LhaPlusがあるフォルダをカレントディレクトリに指定
    WSH.CurrentDirectory = "C:\Program Files (x86)\Lhaplus"

    If Right(targetPath, 1) <> "\" Then targetPath = targetPath & "\"

    If fso.FolderExists(targetPath) = False Then
    MsgBox "圧縮対象フォルダが存在しません。" & vbCrLf & targetPath, vbCritical + vbOKOnly, "zip作成エラー"
    Exit Function
    End If

    i = -1
    j = 0
    fileSize = 0
    FileName = Dir(targetPath & "*.jpg", vbNormal)
    Do While FileName <> ""
    i = i + 1
    ReDim Preserve targetFile(i)
    targetFile(i) = targetPath & FileName
    fileSize = fileSize + fso.GetFile(targetFile(i)).Size
    If fileSize >= maxFileSizeBytes Then
    j = j + 1
    CreateZipFile targetFile, targetPath, j, fso, WSH
    ReDim targetFile(0)
    i = -1
    fileSize = fso.GetFile(targetPath & FileName).Size ' 新しいファイルサイズの計算をリセット
    End If
    FileName = Dir()
    Loop

    ' 残りのファイルを圧縮
    If i >= 0 Then
    j = j + 1
    CreateZipFile targetFile, targetPath, j, fso, WSH
    End If

    Set fso = Nothing
    Set WSH = Nothing

    lhaplus_zip = True
    End Function

    Private Sub CreateZipFile(targetFile() As String, targetPath As String, j As Long, fso As Object, WSH As Object)
    Dim Cmd As String
    Dim zipFileName As String

    ' ZIPファイル名を定義
    zipFileName = "archive" & j & ".zip"

    ' 圧縮リストファイルを作成
    With fso.CreateTextFile(targetPath & "圧縮リスト" & j & ".txt")
    .WriteLine Join(targetFile, vbCrLf)
    .Close
    End With

    ' Lhaplusを使用してZIPファイルを作成
    Cmd = "Lhaplus.exe /c:zip /n:" & targetPath & zipFileName & " /l:" & targetPath & "圧縮リスト" & j & ".txt"
    WSH.Run "%ComSpec% /c " & Cmd, 7, True

    ' 圧縮リストファイルを削除
    fso.DeleteFile targetPath & "圧縮リスト" & j & ".txt"
    End Sub

複数のRakuten領収書から「インボイス制度」に必要な情報抽出&タイトル変更

    Rakuten注文履歴からダウンロードした、複数のPDFファイルから
    「インボイス制度」や「電子帳簿保存法」に必要な情報を
    抽出しリスト化と検索しやすいファイル名に変更するツールを作成致しました。
    「インボイス制度」や「電子帳簿保存法」による手間を激減できます。


    販売ページ 500円
    Excelで簡単操作! Rakuten…
    ※Adobe Acrobat(無料)のインストールが必要です。
    ※Microsoft Excelを使用します。


    動画


    使用VBAコード----------
    こちら、13段階の処理を行っており
    表示は、長すぎるためこちらではいたしません。
    販売品の、コードにはロックはかけておりませんので
    自己責任で、自由に改造してください。


New フォルダー内の複数のPDFファイルから内容を抽出してファイルを検索

    PDFファイルをフォルダーに整理しておくことで、それぞれの内容を一括で抽出し
    特定の検索文字列に基づいてファイルを見つけ出すことが可能です。
    このシステムを利用することにより、必要なPDFファイルを一つ一つ開いて探す手間が省け
    効率的に目的のファイルを見つけることができます。
    また、フォルダーに新しいファイルが追加された場合でも、既に処理されたファイルは
    再び処理されないように設計されています。
    したがって、一度処理したExcelファイルを保存しておけば、新たに追加されたファイルのみが処理されるため
    全体の処理時間の短縮が可能です。
    ※OCR等でテキスト化されていないファイルは、処理できません。


    無料ダウンロード
    フォルダー内の複数のPDFファイルから内容を抽出してファイルを検索
    ※Microsoft Excelを使用します。
    ※Adobe Acrobat(無料)のインストールが必要です。


    動画


    使用VBAコード----------
    実行モジュール

    Sub 正方形長方形1_Click()
    '
    Call change_pdf_to_txt
    Call ListTextFiles
    Call ListMatchingFilesContent
    Call deleteTextFiles

    Call ClearColumnF

    End Sub

    Sub ClearColumnF()
    ' 最後の行を見つける
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, "F").End(xlUp).row

    ' F2から最後の行までの範囲をクリアする
    Range("F2:F" & LastRow).ClearContents
    End Sub

    Sub 正方形長方形2_Click()
    Dim ws As Worksheet
    Dim LastRow As Long, i As Long, fRow As Long
    Dim searchString As String
    Dim prefixString As String
    Dim resultString As String
    Dim hyperlinkFormula As String

    Call ClearColumnF

    Set ws = ThisWorkbook.Sheets("実行") ' Update the sheet name as necessary
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    searchString = ws.Range("L12").Value ' Get search string from cell L12
    prefixString = ws.Range("L7").Value ' Get prefix string from cell L7
    fRow = 2 ' Starting row for column F

    For i = 2 To LastRow
    ' Search for the value of cell L12 in columns A and B
    If InStr(1, ws.Cells(i, 1).Value, searchString) > 0 Or _
    InStr(1, ws.Cells(i, 2).Value, searchString) > 0 Then
    ' Construct the result string
    resultString = prefixString & "\" & ws.Cells(i, 1).Value & ".pdf"
    ' Create the hyperlink formula
    hyperlinkFormula = "=HYPERLINK(""" & resultString & """, """ & ws.Cells(i, 1).Value & """)"
    ' Set the formula for the next empty cell in column F
    ws.Cells(fRow, 6).Formula = hyperlinkFormula
    fRow = fRow + 1 ' Move to the next empty cell
    End If
    Next i

    Call FillSpaceInGIfFNotEmpty

    End Sub


    Sub FillSpaceInGIfFNotEmpty()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("実行") ' シート名を適宜変更してください

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).row ' F列の最終行を取得

    Dim i As Long
    For i = 1 To LastRow
    If ws.Cells(i, "F").Value <> "" Then ' F列が空でない場合
    ws.Cells(i, "G").Value = " " ' G列にスペースを挿入
    End If
    Next i
    End Sub










    1、テキスト化------------------------------------------------

    Sub change_pdf_to_txt()

    Dim objAcroApp As New Acrobat.AcroApp
    Dim objAcroAVDoc As Acrobat.AcroAVDoc
    Dim objAcroPDDoc As Acrobat.AcroPDDoc
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim lRet As Long
    Dim jso As Object
    Dim sFolderPath As String
    Dim sFileName As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim processFile As Boolean

    ' ExcelからフォルダパスとA列のデータを取得
    sFolderPath = ThisWorkbook.Sheets("実行").Range("L7").Value
    Set ws = ThisWorkbook.Sheets("実行")
    Set rng = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).row)

    ' FileSystemObjectを作成
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' フォルダを取得
    Set objFolder = objFSO.GetFolder(sFolderPath)

    ' Acrobatアプリケーションを起動する。
    lRet = objAcroApp.Show

    ' 指定されたフォルダ内のすべてのPDFを処理
    For Each objFile In objFolder.Files
    If objFSO.GetExtensionName(objFile.Name) = "pdf" Then
    ' PDFファイル名を取得(拡張子なし)
    sFileName = objFSO.GetBaseName(objFile.Name)

    ' エクセルのA列に含まれる文字列と一致するかチェック
    processFile = True
    For Each cell In rng
    If InStr(sFileName, cell.Value) > 0 Then
    processFile = False
    Exit For
    End If
    Next cell

    ' 条件に一致したらスキップ
    If Not processFile Then
    ' スキップする処理
    GoTo SkipFile
    End If

    ' PDFファイルを開いて表示する。
    Set objAcroAVDoc = New Acrobat.AcroAVDoc
    lRet = objAcroAVDoc.Open(objFile.Path, "")

    ' PDDocオブジェクトを取得する
    Set objAcroPDDoc = objAcroAVDoc.GetPDDoc()

    ' JavaScriptオブジェクトを作成する。
    Set jso = objAcroPDDoc.GetJSObject

    ' PDFをテキストに変換する(ファイル名はPDFと同じ)。
    jso.SaveAs sFolderPath & "\" & sFileName & ".txt", "com.adobe.acrobat.accesstext"

    ' PDFファイルを閉じます。
    lRet = objAcroAVDoc.Close(1)

    ' オブジェクトを開放する。
    Set objAcroPDDoc = Nothing
    Set objAcroAVDoc = Nothing

    SkipFile:
    End If
    Next objFile

    ' Acrobatアプリケーションを終了する。
    lRet = objAcroApp.Hide
    lRet = objAcroApp.Exit

    ' オブジェクトを開放する。
    Set objFolder = Nothing
    Set objFSO = Nothing
    Set objAcroApp = Nothing

    End Sub










    2、ファイル名の抽出------------------------------------------------

    Sub ListTextFiles()
    Dim folderPath As String
    Dim fileName As String
    Dim i As Integer
    Dim ws As Worksheet
    Dim cell As Range



    ' セルL7からフォルダーパスを取得
    folderPath = ThisWorkbook.Sheets("実行").Range("L7").Value

    ' フォルダーパスの末尾にバックスラッシュがなければ追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    ' フォルダー内の最初のテキストファイルを検索
    fileName = Dir(folderPath & "*.txt")

    ' 初期化
    i = 2 ' A2セルから開始

    ' ファイルが見つかった場合、リストに追加
    While fileName <> ""
    ThisWorkbook.Sheets("実行").Cells(i, 1).Value = fileName
    i = i + 1
    fileName = Dir() ' 次のファイルを検索
    Wend

    '拡張子の削除
    Set ws = ThisWorkbook.Sheets("実行") ' シート名を適宜変更してください

    For Each cell In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, 1).End(xlUp).row)
    cell.Value = Replace(cell.Value, ".txt", "")
    Next cell
    End Sub










    2、内容の抽出------------------------------------------------

    Sub ListMatchingFilesContent()
    Dim folderPath As String
    Dim fileName As String
    Dim searchText As String
    Dim fileContent As String
    Dim LastRow As Integer
    Dim i As Integer

    With ThisWorkbook.Sheets("実行")
    ' A列の最後の行を取得
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).row

    ' L7セルからフォルダーパスを取得
    folderPath = .Cells(7, "L").Value

    ' フォルダーパスの末尾にバックスラッシュがなければ追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    ' 各行について処理
    For i = 1 To LastRow
    searchText = .Cells(i, "A").Value

    ' フォルダ内のテキストファイルを検索
    fileName = Dir(folderPath & "*.txt")

    ' テキストファイルを検索し続ける
    While fileName <> ""
    ' A列の文字列でファイルをフィルタリング
    If InStr(1, fileName, searchText) > 0 Then
    ' ファイルの内容を読み込む
    fileContent = GetFileContent(folderPath & fileName)
    ' ファイルが空でない場合のみ処理
    If fileContent <> "" Then
    .Cells(i, "B").Value = fileContent ' A列と同じ行のB列に内容を設定
    End If
    End If
    fileName = Dir() ' 次のファイルを検索
    Wend
    Next i
    End With


    Call FillSpaceInGIfFNotEmpty

    End Sub

    ' ファイルの内容を読み取る関数
    Function GetFileContent(filePath As String) As String
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")

    With stream
    .Charset = "utf-8"
    .Open
    .LoadFromFile filePath
    GetFileContent = .ReadText
    .Close
    End With
    End Function


    Sub FillSpaceInGIfFNotEmpty()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("実行") ' シート名を適宜変更してください

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row ' F列の最終行を取得

    Dim i As Long
    For i = 1 To LastRow
    If ws.Cells(i, "A").Value <> "" Then ' F列が空でない場合
    ws.Cells(i, "C").Value = " " ' C列にスペースを挿入
    End If
    Next i
    End Sub










    2、テキストファイルの削除------------------------------------------------

    Sub deleteTextFiles()
    Dim folderPath As String
    Dim file As String

    ' L7セルからフォルダパスを取得
    folderPath = ThisWorkbook.Sheets("実行").Range("L7").Value

    ' フォルダパスの有効性を確認
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    ' 指定フォルダ内のすべてのテキストファイルを削除
    file = Dir(folderPath & "*.txt")
    Do While file <> ""
    Kill folderPath & file
    file = Dir
    Loop

    ' MsgBox "すべてのテキストファイルが削除されました。", vbInformation
    End Sub


New サブフォルダを含めたフォルダー内のPDFファイル/ Excelファイルから内容を抽出してファイルの検索を容易にし、お仕事を少し楽にするツール

    指定フォルダから、PDFファイルとExcelファイルの「内容」と「ファイル名」を一括で抽出し
    文字列から、ファイルを検索することが可能です。
    ご指定フォルダーのみではなく、サブフォルダーを含めた、全てのファイルが検索対象になります。

    このシステムを利用することにより、必要なPDFファイルやExcelファイルを一つ一つ開いて、内容を確認し探す手間が省け
    効率的に目的のファイルを見つけることができます。

    また、フォルダーに新しいファイルが追加された場合でも、既に処理されたファイルは
    再び処理されないように設計されています。
    一度処理したExcelファイルを保存しておけば、新たに追加されたファイルのみが処理されるため
    全体の処理時間の短縮が可能です。

    ※OCR等でテキスト化されていないファイルは、処理できません

    ※こちら、情報を送信する等の機能は備えておりません。
    プログラムには、ロックをかけておりませんので、開発から自由にVBAをご確認ください。

    販売ページ 110円
    フォルダー内のPDFファイル/ Excelファ…
    ※Adobe Acrobat(無料)のインストールが必要です。
    ※Microsoft Excelを使用します。


    動画


    使用VBAコード----------
    販売品の、コードにはロックはかけておりませんので
    自己責任で、自由に改造してください。



HOME