「メモ」ファイルA、Bを開きA列が一致する場合、ファイルAからBへB~D列をコピーする

Sub CopyMatchingRows()
    Dim wbA As Workbook
    Dim wbB As Workbook
    Dim wsA As Worksheet
    Dim wsB As Worksheet
    Dim filePathA As String
    Dim filePathB As String
    Dim lastRowA As Long
    Dim lastRowB As Long
    Dim i As Long
    Dim j As Long
    
    ' ファイルのパスを指定
    filePathA = "C:\path\to\fileA.xlsx"
    filePathB = "C:\path\to\fileB.xlsx"
    
    ' ファイルAとファイルBを開く
    Set wbA = Workbooks.Open(filePathA)
    Set wbB = Workbooks.Open(filePathB)
    
    ' シートを設定（例：最初のシート）
    Set wsA = wbA.Sheets(1)
    Set wsB = wbB.Sheets(1)
    
    ' 最終行を取得
    lastRowA = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row
    lastRowB = wsB.Cells(wsB.Rows.Count, "A").End(xlUp).Row
    
    ' ファイルAのキー列をループ
    For i = 2 To lastRowA ' ヘッダーがある場合、2行目から開始
        For j = 2 To lastRowB ' ヘッダーがある場合、2行目から開始
            If wsA.Cells(i, 1).Value = wsB.Cells(j, 1).Value Then
                ' ファイルAのB列～D列の値をファイルBの対応する行にコピー
                wsB.Cells(j, 2).Value = wsA.Cells(i, 2).Value
                wsB.Cells(j, 3).Value = wsA.Cells(i, 3).Value
                wsB.Cells(j, 4).Value = wsA.Cells(i, 4).Value
                Exit For ' マッチしたら内側のループを抜ける
            End If
        Next j
    Next i
    
    ' ファイルを保存して閉じる
    wbA.Close SaveChanges:=False
    wbB.Close SaveChanges:=True
    
    ' クリア
    Set wsA = Nothing
    Set wsB = Nothing
    Set wbA = Nothing
    Set wbB = Nothing
End Sub

EXCEL VBA AcrobatReaderやAdobeを使わずにPDFのページ数を取得する方法(ChatGPT編)

このブログで一番アクセスの多い記事について、

今流行のChatGPTさんに聞いてみました。

結果としては、以下の通りです。

/Count要素と/Type /Page要素以外の要素を使用してページ数を取得するためには、

PDFファイルのフォーマットを詳しく調べる必要があります。

PDFファイルのフォーマットに関する詳細は、Adobe Systemsが提供する

「PDFリファレンス」に記載されています。

PDFファイルにはカタログオブジェクト、ページツリー、アウトラインツリー、暗号化設定など、

ページに直接関係しないオブジェクトも含まれるため、ページ数を取得することは非常に困難です。

したがって、ページ数を取得するためには、PDFファイルのフォーマットについて詳しく調査し、

ページに関連するオブジェクトの特徴を把握し、適切な方法を選択する必要があります。

一般的には、/Count要素や/Type /Page要素を使用する方法が最も簡単で確実です。

PDFファイルのページを判別するための要素には、以下のようなものがあります。

/Count要素：この要素は、PDFファイル内のページ数を示します。

/Type /Page要素：この要素は、PDFファイル内の各ページを示します。

　　　　　　　　 PDFファイル内のページ数は、この要素の数に等しいです。

/Resources要素：この要素には、ページ内で使用されるフォント、イメージ、色空間などが含まれています。 /Contents要素：この要素には、ページのコンテンツが含まれています。

/MediaBox要素：この要素には、ページのメディアボックスのサイズが含まれています。

/CropBox要素：この要素には、ページのクロップボックスのサイズが含まれています。

/Rotate要素：この要素には、ページの回転角度が含まれています。

/Parent要素：この要素は、ページツリー内の親ページを示します。

/Annots要素：この要素には、ページに関連する注釈が含まれています。

以下は、AcrobatReaderやAdobeを使用せず、PDFファイルからページ数を取得するVBAコードの例です。

このコードは、まず指定されたPDFファイルをバイナリ形式で開き、

ファイルの内容を文字列として読み込みます。

その後、/Count要素が存在するかどうかを確認し、存在する場合はそれを使用してページ数を取得し、

存在しない場合は指定された要素を順に検索して最初に見つかった要素を使用してページ数を取得します。

最後に、ページ数をメッセージボックスで表示します。

Sub GetPageCount()

    Dim filePath As String
    filePath = "C:\example.pdf" ' PDFファイルのパスを指定する
    
    Dim pdfContent As String
    Open filePath For Binary Access Read As #1
    pdfContent = Space$(LOF(1))
    Get #1, , pdfContent
    Close #1
    
    Dim pageCount As Long
    pageCount = 0
    
    ' /Count要素が存在する場合は、それを使用してページ数を取得する
    If InStr(pdfContent, "/Count ") > 0 Then
        pageCount = CInt(Mid$(pdfContent, InStr(pdfContent, "/Count ") + 7, InStr(pdfContent, " ") - InStr(pdfContent, "/Count ") - 7))
    Else
        ' それ以外の要素でページ数を取得する
        Dim searchElements As Variant
        searchElements = Array("/Type /Page", "/Resources", "/Contents", "/MediaBox", "/CropBox", "/Rotate", "/Parent", "/Annots")
        For Each elem In searchElements
            If InStr(pdfContent, elem) > 0 Then
                pageCount = Len(pdfContent) - Len(Replace(pdfContent, elem, "")) / Len(elem)
                Exit For
            End If
        Next elem
    End If
    
    MsgBox "PDFファイルのページ数は " & pageCount & " ページです。"

End Sub

プライバシーポリシー

・個人情報の取得

当ブログではお問い合わせフォームや記事へのコメントの際にメールアドレス等の個人情報を
入力いただくことがあり、個人情報と合わせて送信元のIPアドレスを取得しています。
入力いただいた個人情報は、お問い合わせに対する回答やご連絡を要する場合、また、嫌がらせなど
お問い合わせフォームの悪用があった場合に利用します。これらの目的以外での利用はいたしません。

・Cookieの利用

当ブログでは、閲覧者の興味に応じた広告を表示したりブログの閲覧状況を測定するため、
第三者企業によるクッキー（Cookie）、画像ファイル（ウェブビーコン）などを利用しています。
これらクッキーは第三者企業が直接ご利用の端末情報を取得し、各企業の定めるプライバシーポリシーに
従って管理されます。

クッキーから得られる情報は匿名であり、閲覧者個人を特定することはできません。
また、目的外の用途で利用されることもありません。

閲覧者は第三者企業のサイトにアクセスし、個別にクッキーの無効化など設定を行うことが可能です。
また、クッキーの送受信に関する設定で「クッキーの送受信を拒否する」といった選択を行い、
クッキーの送受信を拒否したり、https://optout.aboutads.info にて 第三者企業のCookieを無効に
することができます。

当サイトで利用している企業、サービスは下記の通りです。詳細は各企業サイトにてご確認ください。

 Google AdSense （https://policies.google.com/technologies/ads?gl=jp）

・コメントについて

はてなブログでは、ゲストがブログへのコメントを残す際にブログ作者にIP アドレスが公開されます。
これは、嫌がらせやスパム行為への対応といった運営管理のために設定されている機能であり、
目的外に利用したりみだりに公開することはいたしません。

■

追加で二人倒れて

ついにそのグループは消滅した

生存確認

隣のプロジェクトが炎上しているのでヘルプに入っている。

二人精神的に倒れて、もう一人倒れそう笑

EXCEL VBA Wordファイルの指定ページを章番号を含めエクセルに貼り付けたい

ワードの指定ページを章番号等をまるまるエクセル貼り付けたいと思って調べたら大変だったので結果をまとめて記載する。

まあ、そもそもワードのページをエクセルに貼り付けるとかやってることはクソだが、仕方ない。

検索をするとエクセルの表などをワードに取り込む方法ばかりヒットする。

検索意図と真逆の結果がヒットするのどうにかならんのか。

◆最終的な対応方法

章番号を文字列に変換してからページをコピーし貼り付ける方法でうまくいった。

ただし、章番号を文字列に変換した際、章番号の開始位置がずれてしまう。

この謎仕様は放置した。

■VBAでマクロを作成中に発生した問題点

◆問題点①：ワードのページをコピーしてエクセルに貼り付けると、章番号が保持されない。

　⇒章番号を文字列に変換してからページをコピーして解決。

　Selection.Range.ListFormat.ConvertNumbersToText NumberType:=wdNumberParagraph

　Selection.Range.ListFormat.ConvertNumbersToText NumberType:=wdNumberAllNumber

　Selection.Range.ListFormat.ConvertNumbersToText NumberType:=wdNumberListNumber

◆問題点②：ワードのページをコピーしてエクセルに貼り付けると、表などの背景色が青や黒に変わってしまう。

　⇒問題となった部分の背景色を白で塗りつぶして暫定対応

　Selection.Shading.BackgroundPatternColor = -603914241

以下ソース ワードを章番号を含めて1ページ目から最終ページまでをコピーして エクセルに貼り付けるマクロ

Sub WordCopy()
    Const wdGoToPage=1
    Const wdGoToFirst=1
    Const wdNumberOfPagesInDocument=4
    Const wdPrintView=3
    Const wdNumberParagraph = 1
    Const wdNumberListNum = 2
    Const wdNumberAllNumbers = 3
    Const wdStory = 6
    
    Dim Full_FilePath as String
    Full_FilePath = "***.docx"
    
    Dim objWord As Object
    Dim wdDoc As Object
    
    Set objWord = CreateObject("Word.Application")
    'ワードを起動
    objWord.Visible = True
    
    Set wdDoc = objWord.Documents.Open(Full_FilePath)
    
    Dim Pages As Long
    Dim num As Long
    Dim Rows As Long 'エクセルのページの貼り付け行位置
    Rows = 1
    '表示形式を印刷プレビュー形式に設定
    objWord.ActiveWindow.View.Type = wdPrintView
    
    '全体を選択
    objWord.Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst,Count:=1
    objWord.Selection.WholeStory
    '編集を禁止
    objWord.Selection.Fields.Locked = True
    '段落番号、リスト番号、数値を文字列に変換
    objWord.Selection.Range.ListFormat.ConvertNumbersToText NumberType:=wdNumberParagraph
    objWord.Selection.Range.ListFormat.ConvertNumbersToText NumberType:=wdNumberListNum
    objWord.Selection.Range.ListFormat.ConvertNumbersToText NumberType:=wdNumberAllNumbers
    '総ページ数を取得
    Pages = wdDoc.Content.Information(wdNumberOfPagesInDocument)
    
    Dim myEnd As Long
    For num=1 to Pages
        if num <= Pages Then
            If num = Pages Then
                '最終ページはページの最後までを選択
                objWord.Selection.EndKey Unit:=wdStory
                myEnd = objWord.Selection.End
                objWord.Selection.GoTo What:=wdGoToPage,Which:=wdGoToFirst,Count:=num
                objWord.Selection.End = myEnd
                ’この処理は完全に任意
                '表の背景が青や黒になってしまう場合、背景色を白で塗りつぶして対応したが、最善策ではない。
                objWord.Selection.Shading.BackGroundPatternColor=-603914241
            Else
                objWord.Selection.GoTo What:=wdGoToPage,Count:=num+1
                myEnd = objWord.Selection.End

                objWord.Selection.GoTo What:=wdGoToPage,Which:=wdGoToFirst,Count:=num+1
                myEnd = objWord.Selection.Start-1
                objWord.Selection.GoTo What:=wdGoToPage,Which:=wdGoToFirst,Count:=num
                myEnd = objWord.Selection.End                
                
            End If
            
            objWord.Selection.Copy
            Range(Cells(Rows,1),Cells(Rows,1)).Select
            ActiveSheet.PasteSpecial Format:="Microsoft Word文書オブジェクト",Link=False,DisplayAsIcon:=False
            'ActiveSheet.PasteSpecial Format:="図（拡張メタファイル）",Link=False,DisplayAsIcon:=False
            '1ページだいたい65行
            Rows = Rows+65
        End If
    Next
    
    Application.DisplayAlerts = False
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    
    objWord.Visible = False
    objWord.Quit SaveCHanges:=False
    Set wdDoc = Nothing
    Set objWord = Nothing
End Sub

夏季休暇なし！

夏季休暇なし！