Excel VBA 一行一行、結合セルで作られた報告書にうまい具合に幅を合わせて自動入力してくれるマクロ
一行一行、結合されたセルに入力していくJapaneseスタイルの報告書作成を楽にするマクロです。
以前作ったものは英語版だけでしたが、今回は、日本語も対応した改良版です。64ビットだと動かないかも。
あのVBAの大家 t-hom’s diary さんが日本語を扱える素晴らしいコードを書いてらっしゃるのでそちらをベースにして作りました。基のテキストにあわせて改行するように手を加えました。
＜実行後のイメージ＞
＜下準備＞
まず、メモ帳その他テキストエディタで、改行を含め、普通に編集したテキストを用意してください。
次に、下図のように、一行一行セルを結合してつくられたクレイジーな報告書を用意してください。
書式設定ですべての行に同じフォントを設定してください。
＜使い方＞
1. 開始位置の行に基準文字列(横幅を決めるため)を入力。
2. メモ帳などで編集したテキストをクリップボードにコピー。
3. Excelに戻り、開始位置の行を選択。
4. 当該マクロJustifyLinesを実行。
ソースコード
下のコードを標準モジュールに貼り付けてください。
（注意） 参照設定でMicrosoft Forms 2.0 Object Libraryにチェックを入れておいてください。
Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, _ ByVal nWidth As Long, _ ByVal nEscapement As Long, _ ByVal nOrientation As Long, _ ByVal fnWeight As Long, _ ByVal IfdwItalic As Long, _ ByVal fdwUnderline As Long, _ ByVal fdwStrikeOut As Long, _ ByVal fdwCharSet As Long, _ ByVal fdwOutputPrecision As Long, _ ByVal fdwClipPrecision As Long, _ ByVal fdwQuality As Long, _ ByVal fdwPitchAndFamily As Long, _ ByVal lpszFace As String) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, _ ByVal lpStr As String, _ ByVal nCount As Long, _ lpRect As RECT, _ ByVal wFormat As Long) As Long
Private Const FW_NORMAL = 400 Private Const FW_BOLD = 700 Private Const DEFAULT_CHARSET = 1 Private Const OUT_DEFAULT_PRECIS = 0 Private Const CLIP_DEFAULT_PRECIS = 0 Private Const DEFAULT_QUALITY = 0 Private Const DEFAULT_PITCH = 0 Private Const FF_SCRIPT = 64 Private Const DT_CALCRECT = &H400 '文字の横幅を返す Function MeasureTextWidth( _ target_text As String, _ FONT_NAME As String, _ Optional font_height As Long = 10) As Long Dim hWholeScreenDC As Long: hWholeScreenDC _ = GetDC(0&) Dim hVirtualDC As Long: hVirtualDC _ = CreateCompatibleDC(hWholeScreenDC)
Dim hFont As Long: hFont _ = CreateFont(font_height, 0, 0, 0, FW_NORMAL, _ 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, _ CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _ DEFAULT_PITCH Or FF_SCRIPT, FONT_NAME) Call SelectObject(hVirtualDC, hFont) Dim DrawAreaRectangle As RECT Call DrawText(hVirtualDC, target_text, -1, DrawAreaRectangle, DT_CALCRECT) Call DeleteObject(hFont) Call DeleteObject(hVirtualDC) Call ReleaseDC(0&, hWholeScreenDC) MeasureTextWidth = DrawAreaRectangle.Right - DrawAreaRectangle.Left End Function
'対象文字列を基準文字列の長さに分割して配列に入れて返す Function getJustifiedLines(rulerText As String, srcText As String, fontName As String) Dim rulerTextLen As Long '基準になるテキストの長さ rulerTextLen = MeasureTextWidth(rulerText, fontName) Dim tmpText As String Dim curChar As String Dim i As Long Dim lineArray(): ReDim lineArray(0) Dim arrayIndex As Long For i = 1 To Len(srcText) curChar = Mid(srcText, i, 1) '現在の文字 tmpText = tmpText & curChar '現在の文字を文字列に連結 '文字列の長さが基準テキストの長さと同じになった場合、 'または、現在の文字が改行コードLFの場合 If MeasureTextWidth(tmpText, fontName) = rulerTextLen _ Or curChar = vbLf Then '配列の要素を一つ増やして、文字列を格納する ReDim Preserve lineArray(arrayIndex) lineArray(arrayIndex) = Replace(tmpText, vbLf, "") arrayIndex = arrayIndex + 1 tmpText = "" End If Next '最後の行 ReDim Preserve lineArray(UBound(lineArray) + 1) lineArray(UBound(lineArray)) = tmpText getJustifiedLines = lineArray End Function
Sub JustifyLines() 'アクティブセルのテキストを基準にする Dim oriRange As Range: Set oriRange = ActiveCell Dim rulerText As String: rulerText = oriRange.Value Dim fontName As String: fontName = oriRange.Font.Name 'クリップボードに保存されているテキストを対象にする Dim srcText As String With New DataObject .GetFromClipboard srcText = .GetText End With
Dim lineArray As Variant lineArray = getJustifiedLines(rulerText, srcText, fontName) '一行ずつセルに収める Dim i As Long For i = LBound(lineArray) To UBound(lineArray) oriRange.Offset(i, 0).Value = lineArray(i) Next End Sub
