インボイス制度によって複雑化したヤフーショッピングの「受取明細」と「請求明細」を簡単にまとめるシステム

2024年3月15日 13:59

インボイス制度が始まってから、Yahoo!ショッピングの「受取明細」と「請求明細」が項目ごとに分かれており、整理が難しくなっています。
これが、正確であることは理解しますが、80枚近くもあるPDFファイルから一覧を作成するのは非常に困難です。
税理士に依頼しても、恐らく快くは思われないでしょう。
他の出店者の方々はどのように対応されているのでしょうか?

消費税額も無視できる金額ではないため、PDFからデータを抽出して一覧にまとめるシステムを開発しました。

必要なソフトウェア

-Microsoft Excel
-Adobe Acrobat Reader（無料版でOK）

利用方法

Microsoft Excelを開きます。
1行目に以下の項目をAからHまで設定します

ファイル名
期間
内容
金額
税率
消費税
インボイス番号
会社名

後は、VBAエディタに下記のコードを入力して
「L7」セルにPDFファイルが格納されている「フォルダのパス」を入力し、ボタンを押せば実行します。

流石に工程が多いため、ご連絡いただければ、ボランティアでシステムの完成品を添付したEメールを送信いたします!

動作動画

実行ボタンに仕込むコード

Sub 正方形長方形1_Click()
'
Call change_pdf_to_txt_per_page
Call RemoveSpacesFromTextFiles
Call ListTxtFiles
Call order_number10
Call CopySubstringToColumnCFromB2
Call RemoveTextAndZeroFromColumnB
Call order_number
Call order_number2
Call order_number3
Call RemoveText
Call order_number4
Call RemoveText2
Call UpdateColumnH
Call DeleteRowsBasedOnCellValue
Call DeleteTextFiles
Call Sort
Call InsertBlankRowsInEAndH
Call DrawLineWhenDifferentIncludingBlanks
Call SumUntilBlankInColumnDAndF

MsgBox "完了"

End Sub

PDFファイルをページごとにテキスト化

Sub change_pdf_to_txt_per_page()

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 pageNum As Integer
Dim wordIndex As Integer
Dim pageText As String
Dim wordCount As Integer

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

' 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)
        
        ' PDFファイルを開いて表示する。
        Set objAcroAVDoc = New Acrobat.AcroAVDoc
        lRet = objAcroAVDoc.Open(objFile.Path, "")
        
        ' PDDocオブジェクトを取得する
        Set objAcroPDDoc = objAcroAVDoc.GetPDDoc()
        
        ' JavaScriptオブジェクトを作成する。
        Set jso = objAcroPDDoc.GetJSObject
        
        ' PDF内のページ数を取得
        Dim numPages As Integer
        numPages = objAcroPDDoc.GetNumPages()
        
        ' 各ページを個別のテキストファイルとして保存
        For pageNum = 0 To numPages - 1
            pageText = ""
            wordCount = jso.getPageNumWords(pageNum)
            
            ' すべての単語の座標を取得し、テキストを組み立てる
            For wordIndex = 0 To wordCount - 1
                Dim quads
                quads = jso.getPageNthWordQuads(pageNum, wordIndex)
                If Not IsNull(quads) Then
                    pageText = pageText & jso.getPageNthWord(pageNum, wordIndex, False) & " "
                End If
            Next wordIndex
            
            ' テキストファイルとしてUnicode（UTF-8）で保存
            Dim txtStream
            Set txtStream = CreateObject("ADODB.Stream")
            txtStream.Charset = "utf-8"
            txtStream.Open
            txtStream.WriteText pageText
            txtStream.SaveToFile sFolderPath & "\" & sFileName & "_" & (pageNum + 1) & ".txt", 2 ' 2 = adSaveCreateOverWrite
            txtStream.Close
        Next pageNum
        
        ' PDFファイルを閉じます。
        lRet = objAcroAVDoc.Close(1)
        
        ' オブジェクトを開放する。
        Set objAcroPDDoc = Nothing
        Set objAcroAVDoc = Nothing
    End If
Next objFile

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

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

End Sub

Excelから指定されたフォルダ内のテキストファイルからスペースを削除する

Sub RemoveSpacesFromTextFiles()
    Dim folderPath As String
    Dim fileName As String
    Dim textData As String
    Dim stream As Object
    Dim fso As Object
    Dim folder As Object
    Dim file As Object

    ' エクセルのL7セルからフォルダパスを取得
    folderPath = Range("L7").Value

    ' 末尾がバックスラッシュでない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    ' FileSystemObjectのインスタンスを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)

    ' フォルダ内の各テキストファイルをループ処理
    For Each file In folder.Files
        ' ファイル名が.txtで終わるかをチェック
        If Right(file.Name, 4) = ".txt" Then
            ' テキストファイルの完全パスを取得
            fileName = folderPath & file.Name

            ' ADODB.Stream オブジェクトを使用してUTF-8としてファイルを開く
            Set stream = CreateObject("ADODB.Stream")
            stream.Open
            stream.Charset = "UTF-8"
            stream.LoadFromFile fileName
            textData = stream.ReadText
            stream.Close

            ' スペースをすべて削除
            textData = Replace(textData, " ", "")

            ' ストリームに書き込んでファイルに保存
            stream.Open
            stream.Charset = "UTF-8"
            stream.WriteText textData
            stream.SaveToFile fileName, 2 ' 2 は SaveCreateOverWrite の意味
            stream.Close
        End If
    Next file
End Sub

指定フォルダ内のテキストファイル一覧をExcelに出力

Sub ListTxtFiles()
    Dim folderPath As String
    Dim txtFile As String
    Dim rowNumber As Integer

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

    ' パスの末尾にバックスラッシュがない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    ' 初期設定
    txtFile = Dir(folderPath & "*.txt")
    rowNumber = 2  ' A2セルから開始

    ' フォルダ内の全ての.txtファイルを走査
    Do While txtFile <> ""
        ' ファイル名をエクセルのA列に入力
        Sheets("実行").Cells(rowNumber, 1).Value = txtFile

        ' 次のファイル名を取得
        txtFile = Dir
        rowNumber = rowNumber + 1
    Loop
End Sub

テキストファイル内の特定範囲のデータをExcelに抽出

Sub order_number10()
    Dim folderPath As String
    Dim fileName As String
    Dim textData As String
    Dim startWord As String
    Dim endWord As String
    Dim startPosition As Integer
    Dim endPosition As Integer
    Dim orderDetails As String
    Dim stream As Object
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim lastRow As Long
    Dim matchRow As Long
    Dim ws As Worksheet
    Dim i As Long  ' 追加した変数定義

    ' シートの指定
    Set ws = ThisWorkbook.Sheets("実行") ' シート名に合わせて変更する

    ' エクセルのL7セルからフォルダパスを取得
    folderPath = ws.Range("L7").Value
    
    ' 末尾がバックスラッシュでない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' FileSystemObjectのインスタンスを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 注文番号と注文日の単語を設定
    startWord = "金額"
    endWord = "%"

    ' シート内の最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    
    ' フォルダ内の各テキストファイルをループ処理
    For Each file In folder.Files
        ' ファイル名が.txtで終わるかをチェック
        If Right(file.Name, 4) = ".txt" Then
            ' テキストファイルの完全パスを取得
            fileName = folderPath & file.Name
            
            ' ADODB.Stream オブジェクトを使用してUTF-8としてファイルを開く
            Set stream = CreateObject("ADODB.Stream")
            stream.Open
            stream.Charset = "UTF-8"
            stream.LoadFromFile fileName
            textData = stream.ReadText
            stream.Close
            
    ' 注文番号から注文日までの文字列を抽出
    startPosition = InStr(textData, startWord) + Len(startWord)
    endPosition = InStr(textData, endWord)
    
    If startPosition > Len(startWord) And endPosition > startPosition Then
        ' 注文詳細を抽出
        orderDetails = Mid$(textData, startPosition, endPosition - startPosition)

        ' 改行を取り除く
        orderDetails = Replace(orderDetails, vbCrLf, "") ' 改行コード (CR+LF)
        orderDetails = Replace(orderDetails, vbCr, "")    ' キャリッジリターン (CR)
        orderDetails = Replace(orderDetails, vbLf, "")    ' ラインフィード (LF)

        ' A列でファイル名と一致する行を探す
        matchRow = 0
        For i = 1 To lastRow
            If ws.Cells(i, 1).Value = file.Name Then
                matchRow = i
                Exit For
            End If
        Next i

        ' 一致する行があればB列にデータを出力
        If matchRow > 0 Then
            ws.Cells(matchRow, 2).Value = Trim$(orderDetails)
        End If
    End If

        End If
    Next file
End Sub

B列から文字列 "2" の位置までの部分文字列をC列にコピーする

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

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).row ' B列で最後の行を見つけます

    Dim i As Long
    For i = 2 To lastRow ' B2から開始
        Dim inputValue As String
        inputValue = ws.Cells(i, 2).Value ' B列の各セルを読み込みます

        Dim position As Integer
        position = InStr(inputValue, "2") ' 文字列 "2" が最初に現れる位置を見つけます

        If position > 0 Then
            ws.Cells(i, 3).Value = Left(inputValue, position - 1) ' "2" までの部分文字列を同じ行のC列にコピー
        Else
            ws.Cells(i, 3).Value = inputValue ' "2" が見つからない場合、全ての文字列をコピー
        End If
    Next i
End Sub

文字列から余計な文字列を省く

Sub RemoveTextAndZeroFromColumnB()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("実行") ' シート名に合わせて調整してください

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

    Dim i As Long
    For i = 2 To lastRow
        Dim cValue As String
        cValue = ws.Cells(i, 3).Value ' C列の値を取得
        Dim bValue As String
        bValue = ws.Cells(i, 2).Value ' B列の値を取得

        ' B列からC列の文字列を削除
        If InStr(bValue, cValue) > 0 Then
            bValue = Replace(bValue, cValue, "")
        End If

        ' B列の最後の文字が「0」の場合、それを削除
        If Right(bValue, 1) = "0" Then
            bValue = Left(bValue, Len(bValue) - 1)
        End If
        
        If Right(bValue, 1) = "1" Then
            bValue = Left(bValue, Len(bValue) - 1)
        End If

        ws.Cells(i, 2).Value = bValue ' 更新されたB列の値をセット
    Next i
    
    

    
End Sub

テキストファイルから特定のキーワード間の文字列をExcelの指定列に抽出

Sub order_number()
    Dim folderPath As String
    Dim fileName As String
    Dim textData As String
    Dim startWord As String
    Dim endWord As String
    Dim startPosition As Integer
    Dim endPosition As Integer
    Dim orderDetails As String
    Dim stream As Object
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim lastRow As Long
    Dim matchRow As Long
    Dim ws As Worksheet
    Dim i As Long  ' 追加した変数定義

    ' シートの指定
    Set ws = ThisWorkbook.Sheets("実行") ' シート名に合わせて変更する

    ' エクセルのL7セルからフォルダパスを取得
    folderPath = ws.Range("L7").Value
    
    ' 末尾がバックスラッシュでない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' FileSystemObjectのインスタンスを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 注文番号と注文日の単語を設定
    startWord = "%"
    endWord = "円"

    ' シート内の最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    
    ' フォルダ内の各テキストファイルをループ処理
    For Each file In folder.Files
        ' ファイル名が.txtで終わるかをチェック
        If Right(file.Name, 4) = ".txt" Then
            ' テキストファイルの完全パスを取得
            fileName = folderPath & file.Name
            
            ' ADODB.Stream オブジェクトを使用してUTF-8としてファイルを開く
            Set stream = CreateObject("ADODB.Stream")
            stream.Open
            stream.Charset = "UTF-8"
            stream.LoadFromFile fileName
            textData = stream.ReadText
            stream.Close
            
    ' 注文番号から注文日までの文字列を抽出
    startPosition = InStr(textData, startWord) + Len(startWord)
    endPosition = InStr(textData, endWord)
    
    If startPosition > Len(startWord) And endPosition > startPosition Then
        ' 注文詳細を抽出
        orderDetails = Mid$(textData, startPosition, endPosition - startPosition)

        ' 改行を取り除く
        orderDetails = Replace(orderDetails, vbCrLf, "") ' 改行コード (CR+LF)
        orderDetails = Replace(orderDetails, vbCr, "")    ' キャリッジリターン (CR)
        orderDetails = Replace(orderDetails, vbLf, "")    ' ラインフィード (LF)

        ' A列でファイル名と一致する行を探す
        matchRow = 0
        For i = 1 To lastRow
            If ws.Cells(i, 1).Value = file.Name Then
                matchRow = i
                Exit For
            End If
        Next i

        ' 一致する行があればB列にデータを出力
        If matchRow > 0 Then
            ws.Cells(matchRow, 4).Value = Trim$(orderDetails)
        End If
    End If

        End If
    Next file
End Sub

テキストファイル内の特定キーワード間のデータをExcelに特定列に配置

Sub order_number2()
    Dim folderPath As String
    Dim fileName As String
    Dim textData As String
    Dim startWord As String
    Dim endWord As String
    Dim startPosition As Integer
    Dim endPosition As Integer
    Dim orderDetails As String
    Dim stream As Object
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim lastRow As Long
    Dim matchRow As Long
    Dim ws As Worksheet
    Dim i As Long  ' 追加した変数定義

    ' シートの指定
    Set ws = ThisWorkbook.Sheets("実行") ' シート名に合わせて変更する

    ' エクセルのL7セルからフォルダパスを取得
    folderPath = ws.Range("L7").Value
    
    ' 末尾がバックスラッシュでない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' FileSystemObjectのインスタンスを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 注文番号と注文日の単語を設定
    startWord = "%"
    endWord = "%"

    ' シート内の最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    
    ' フォルダ内の各テキストファイルをループ処理
    For Each file In folder.Files
        ' ファイル名が.txtで終わるかをチェック
        If Right(file.Name, 4) = ".txt" Then
            ' テキストファイルの完全パスを取得
            fileName = folderPath & file.Name
            
            ' ADODB.Stream オブジェクトを使用してUTF-8としてファイルを開く
            Set stream = CreateObject("ADODB.Stream")
            stream.Open
            stream.Charset = "UTF-8"
            stream.LoadFromFile fileName
            textData = stream.ReadText
            stream.Close
            
    ' 注文番号から注文日までの文字列を抽出
    startPosition = InStr(textData, startWord) - 2
    endPosition = InStr(textData, endWord)
    
    If startPosition > Len(startWord) And endPosition > startPosition Then
        ' 注文詳細を抽出
        orderDetails = Mid$(textData, startPosition, endPosition - startPosition)

        ' 改行を取り除く
        orderDetails = Replace(orderDetails, vbCrLf, "") ' 改行コード (CR+LF)
        orderDetails = Replace(orderDetails, vbCr, "")    ' キャリッジリターン (CR)
        orderDetails = Replace(orderDetails, vbLf, "")    ' ラインフィード (LF)

        ' A列でファイル名と一致する行を探す
        matchRow = 0
        For i = 1 To lastRow
            If ws.Cells(i, 1).Value = file.Name Then
                matchRow = i
                Exit For
            End If
        Next i

        ' 一致する行があればB列にデータを出力
        If matchRow > 0 Then
            ws.Cells(matchRow, 5).Value = Trim$(orderDetails)
        End If
    End If

        End If
    Next file
End Sub

テキストファイル内の消費税から合計金額までのデータをExcelに抽出

Sub order_number3()
    Dim folderPath As String
    Dim fileName As String
    Dim textData As String
    Dim startWord As String
    Dim endWord As String
    Dim startPosition As Integer
    Dim endPosition As Integer
    Dim orderDetails As String
    Dim stream As Object
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim lastRow As Long
    Dim matchRow As Long
    Dim ws As Worksheet
    Dim i As Long  ' 追加した変数定義

    ' シートの指定
    Set ws = ThisWorkbook.Sheets("実行") ' シート名に合わせて変更する

    ' エクセルのL7セルからフォルダパスを取得
    folderPath = ws.Range("L7").Value
    
    ' 末尾がバックスラッシュでない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' FileSystemObjectのインスタンスを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 注文番号と注文日の単語を設定
    startWord = "消費税"
    endWord = "合計金額"

    ' シート内の最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    
    ' フォルダ内の各テキストファイルをループ処理
    For Each file In folder.Files
        ' ファイル名が.txtで終わるかをチェック
        If Right(file.Name, 4) = ".txt" Then
            ' テキストファイルの完全パスを取得
            fileName = folderPath & file.Name
            
            ' ADODB.Stream オブジェクトを使用してUTF-8としてファイルを開く
            Set stream = CreateObject("ADODB.Stream")
            stream.Open
            stream.Charset = "UTF-8"
            stream.LoadFromFile fileName
            textData = stream.ReadText
            stream.Close
            
    ' 注文番号から注文日までの文字列を抽出
    startPosition = InStr(textData, startWord) - 2
    endPosition = InStr(textData, endWord)
    
    If startPosition > Len(startWord) And endPosition > startPosition Then
        ' 注文詳細を抽出
        orderDetails = Mid$(textData, startPosition, endPosition - startPosition)

        ' 改行を取り除く
        orderDetails = Replace(orderDetails, vbCrLf, "") ' 改行コード (CR+LF)
        orderDetails = Replace(orderDetails, vbCr, "")    ' キャリッジリターン (CR)
        orderDetails = Replace(orderDetails, vbLf, "")    ' ラインフィード (LF)

        ' A列でファイル名と一致する行を探す
        matchRow = 0
        For i = 1 To lastRow
            If ws.Cells(i, 1).Value = file.Name Then
                matchRow = i
                Exit For
            End If
        Next i

        ' 一致する行があればB列にデータを出力
        If matchRow > 0 Then
            ws.Cells(matchRow, 6).Value = Trim$(orderDetails)
        End If
    End If

        End If
    Next file
End Sub

Excelの指定範囲から特定テキストを削除

Sub RemoveText()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("実行") ' "Sheet1"を対象シートの名前に変更してください

    Dim rng As Range
    Set rng = ws.Range("F2:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).row)

    Dim cell As Range
    For Each cell In rng
        cell.Value = Replace(cell.Value, "消費税", "")
        cell.Value = Replace(cell.Value, "円", "")
    Next cell
End Sub

テキストファイルから事業者登録番号と郵便番号間のデータをExcelに抽出

Sub order_number4()
    Dim folderPath As String
    Dim fileName As String
    Dim textData As String
    Dim startWord As String
    Dim endWord As String
    Dim startPosition As Integer
    Dim endPosition As Integer
    Dim orderDetails As String
    Dim stream As Object
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim lastRow As Long
    Dim matchRow As Long
    Dim ws As Worksheet
    Dim i As Long  ' 追加した変数定義

    ' シートの指定
    Set ws = ThisWorkbook.Sheets("実行") ' シート名に合わせて変更する

    ' エクセルのL7セルからフォルダパスを取得
    folderPath = ws.Range("L7").Value
    
    ' 末尾がバックスラッシュでない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' FileSystemObjectのインスタンスを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 注文番号と注文日の単語を設定
    startWord = "事業者登録番号："
    endWord = "〒"

    ' シート内の最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    
    ' フォルダ内の各テキストファイルをループ処理
    For Each file In folder.Files
        ' ファイル名が.txtで終わるかをチェック
        If Right(file.Name, 4) = ".txt" Then
            ' テキストファイルの完全パスを取得
            fileName = folderPath & file.Name
            
            ' ADODB.Stream オブジェクトを使用してUTF-8としてファイルを開く
            Set stream = CreateObject("ADODB.Stream")
            stream.Open
            stream.Charset = "UTF-8"
            stream.LoadFromFile fileName
            textData = stream.ReadText
            stream.Close
            
    ' 注文番号から注文日までの文字列を抽出
    startPosition = InStr(textData, startWord) - 2
    endPosition = InStr(textData, endWord)
    
    If startPosition > Len(startWord) And endPosition > startPosition Then
        ' 注文詳細を抽出
        orderDetails = Mid$(textData, startPosition, endPosition - startPosition)

        ' 改行を取り除く
        orderDetails = Replace(orderDetails, vbCrLf, "") ' 改行コード (CR+LF)
        orderDetails = Replace(orderDetails, vbCr, "")    ' キャリッジリターン (CR)
        orderDetails = Replace(orderDetails, vbLf, "")    ' ラインフィード (LF)

        ' A列でファイル名と一致する行を探す
        matchRow = 0
        For i = 1 To lastRow
            If ws.Cells(i, 1).Value = file.Name Then
                matchRow = i
                Exit For
            End If
        Next i

        ' 一致する行があればB列にデータを出力
        If matchRow > 0 Then
            ws.Cells(matchRow, 7).Value = Trim$(orderDetails)
        End If
    End If

        End If
    Next file
End Sub

Excelの指定範囲から"事業者登録番号："を削除

Sub RemoveText2()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("実行") ' "Sheet1"を対象シートの名前に変更してください

    Dim rng As Range
    Set rng = ws.Range("G2:G" & ws.Cells(ws.Rows.Count, "G").End(xlUp).row)

    Dim cell As Range
    For Each cell In rng
        cell.Value = Replace(cell.Value, "事業者登録番号：", "")
    Next cell
End Sub

特定の事業者登録番号に基づいて会社名をExcelの列に更新

Sub UpdateColumnH()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("実行") ' "Sheet1" を対象のシート名に変更してください

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

    Dim i As Long
    For i = 1 To lastRow
        If ws.Cells(i, "G").Value = "T4010401039979" Then
            ws.Cells(i, "H").Value = "LINEヤフー株式会社"
        ElseIf ws.Cells(i, "G").Value = "T3180001067019" Then
            ws.Cells(i, "H").Value = "株式会社スズキモータース"
        End If
    Next i
End Sub

特定のセル値を持つ行をExcelで削除

Sub DeleteRowsBasedOnCellValue()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim i As Long

    ' 対象のシートを設定します（ここでは "Sheet1" としています）
    Set ws = ThisWorkbook.Sheets("実行")

    With ws
        ' A列の最終行を取得
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).row

        ' 最終行から上に向かって検索し、条件に合う行を削除
        For i = lastRow To 1 Step -1
            If .Cells(i, 1).Value = "精算明細" Then
                If rng Is Nothing Then
                    Set rng = .Cells(i, 1)
                Else
                    Set rng = Union(rng, .Cells(i, 1))
                End If
            End If
        Next i

        ' 該当する範囲が存在する場合、行を削除
        If Not rng Is Nothing Then
            rng.EntireRow.Delete
        End If
    End With
End Sub

指定フォルダ内の全テキストファイルを削除

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

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

    ' パスの末尾にバックスラッシュがない場合は追加
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

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

    ' ファイルが見つかった場合、削除を行う
    Do While file <> ""
        Kill folderPath & file
        file = Dir
    Loop

   
End Sub

Excelで特定の列に基づいて複数条件でデータを昇順に並び替える

Sub Sort()


    Cells.Select
    Range("A2").Activate
    ActiveWorkbook.Worksheets("実行").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("実行").Sort.SortFields.Add2 Key:=Range("B2:B76"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("実行").Sort.SortFields.Add2 Key:=Range("E2:E76"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("実行").Sort.SortFields.Add2 Key:=Range("H2:H76"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("実行").Sort
        .SetRange Range("A1:X76")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

E列とH列の値が変わる箇所に空白行を挿入

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

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row
    Dim lastRowH As Long
    lastRowH = ws.Cells(ws.Rows.Count, "H").End(xlUp).row

    If lastRowH > lastRow Then lastRow = lastRowH

    Dim i As Long
    For i = lastRow To 3 Step -1
        Dim eDiff As Boolean
        eDiff = (ws.Cells(i, "E").Value <> ws.Cells(i - 1, "E").Value) And (ws.Cells(i, "E").Value <> "" Or ws.Cells(i - 1, "E").Value <> "")

        Dim hDiff As Boolean
        hDiff = (ws.Cells(i, "H").Value <> ws.Cells(i - 1, "H").Value) And (ws.Cells(i, "H").Value <> "" Or ws.Cells(i - 1, "H").Value <> "")

        If eDiff Or hDiff Then
            ws.Rows(i & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        End If
    Next i

End Sub

E列の値が変わる箇所に、A列からH列まで下線を引く


Sub DrawLineWhenDifferentIncludingBlanks()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("実行") ' シート名に合わせて調整してください

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row

    Dim i As Long
    For i = 2 To lastRow
        If ws.Cells(i, "E").Value <> ws.Cells(i + 1, "E").Value Or ws.Cells(i, "E").Value <> "" Or ws.Cells(i + 1, "E").Value <> "" Then
            ws.Range(ws.Cells(i, "A"), ws.Cells(i, "H")).Borders(xlEdgeBottom).LineStyle = xlContinuous
        End If
    Next i
End Sub

D列とF列に空白までの合計を計算し、両列ともゼロの場合に値をクリアする

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

    ' D列の処理
    SumColumn ws, 4 ' D列は列番号4
    ' F列の処理
    SumColumn ws, 6 ' F列は列番号6
    
    Call ClearZeroValuesOnlyIfBothColumnsAreZero
    
End Sub

' 列に対する合計処理を行うサブルーチン
Private Sub SumColumn(ws As Worksheet, colNum As Integer)
    Dim currentRow As Long
    currentRow = 2 ' 開始行

    Dim sum As Double
    sum = 0

    ' 指定した列の最後の行を取得
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).row

    ' 指定した列を下にスクロールして確認
    Do While currentRow <= lastRow
        If IsNumeric(ws.Cells(currentRow, colNum).Value) Then
            sum = sum + ws.Cells(currentRow, colNum).Value
        End If

        ' 次のセルが空欄か、または最終行に達した場合
        If ws.Cells(currentRow + 1, colNum).Value = "" Or currentRow = lastRow Then
            ws.Cells(currentRow + 1, colNum).Value = sum
            sum = 0
            currentRow = currentRow + 2
        Else
            currentRow = currentRow + 1
        End If
    Loop
End Sub


Sub ClearZeroValuesOnlyIfBothColumnsAreZero()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("実行") ' "Sheet1"を対象のシート名に変更してください

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).row

    Dim i As Long
    For i = 1 To lastRow
        If ws.Cells(i, "D").Value = 0 And ws.Cells(i, "F").Value = 0 Then
            ws.Cells(i, "D").ClearContents
            ws.Cells(i, "F").ClearContents
        End If
    Next i
End Sub

この記事が気に入ったらサポートをしてみませんか？