セル結合された行に、幅いっぱいまで文字列を貼り付け、下の行に移って同じ処理を繰り返すマクロ＜日本語は未対応( TДT)＞
追記
（Jan 22, 2019 ）
あの t-hom’s diary さんが日本語を扱える素晴らしいコードを書いてらっしゃるのでそちらを参考にして、別ページで改良版を作りました。
＜使い方＞
メモ帳などで編集したテキストをコピー。Excelに移り、開始位置の行を選択。当該マクロjustifyToMergedRows を実行。
下図のように、一行一行セルを結合してつくられたクレイジーな報告書をよく見かけます。内容を変えるたびにそれ以降、すべての行について改行位置を変更しなければならず、大変面倒です。
予め内容をメモ帳などで完成させておいてから貼り付けるのが賢明ですが、それにしても幅いっぱいまで文字列を選択し貼り付けるという作業を繰り返すのは苦痛です。今回はこの面倒な処理を自動化するマクロを作ってみます。
ポイント
1. 結合セルでできた一行全体の幅をピクセル単位で求める。
2. その行のフォント、サイズ、書体を調べる。
3. 文字列の幅をピクセル単位で求める。
ポイント3については、インターネットで拾ってきた下記のコードを拝借しています。標準モジュールに貼り付けてください。なぜか日本語では上手くいきません。そのうち調べます。
'Option Explicit 'https://stackoverflow.com/questions/5012465/vb-macro-string-width-in-pixel 'API Declares
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As FNTSIZE) As Long Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Const LOGPIXELSY As Long = 90
Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * 32 End Type
Private Type FNTSIZE cx As Long cy As Long End Type Public Function GetLabelPixelWidth(label As String) As Integer Dim font As New StdFont Dim sz As FNTSIZE font.Name = "Tahoma" font.SIZE = 11
sz = GetLabelSize(label, font) GetLabelPixelWidth = sz.cx End Function Public Function GetStringPixelHeight(text As String, fontName As String, fontSize As Single, Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer Dim font As New StdFont Dim sz As FNTSIZE font.Name = fontName font.SIZE = fontSize font.Bold = isBold font.Italic = isItalics sz = GetLabelSize(text, font) GetStringPixelWidth = sz.cy End Function Public Function GetStringPixelWidth(text As String, fontName As String, fontSize As Single, Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer Dim font As New StdFont Dim sz As FNTSIZE font.Name = fontName font.SIZE = fontSize font.Bold = isBold font.Italic = isItalics
sz = GetLabelSize(text, font) GetStringPixelWidth = sz.cx End Function Private Function GetLabelSize(text As String, font As StdFont) As FNTSIZE Dim tempDC As Long Dim tempBMP As Long Dim f As Long Dim lf As LOGFONT Dim textSize As FNTSIZE
' Create a device context and a bitmap that can be used to store a ' temporary font object tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0) tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
' Assign the bitmap to the device context DeleteObject SelectObject(tempDC, tempBMP)
' Set up the LOGFONT structure and create the font lf.lfFaceName = font.Name & Chr$(0) lf.lfHeight = -MulDiv(font.SIZE, GetDeviceCaps(GetDC(0), 90), 72) 'LOGPIXELSY lf.lfItalic = font.Italic ' lf.lfStrikeOut = font.Strikethrough lf.lfUnderline = font.Underline If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400 f = CreateFontIndirect(lf)
' Assign the font to the device context DeleteObject SelectObject(tempDC, f)
' Measure the text, and return it into the textSize SIZE structure GetTextExtentPoint32 tempDC, text, Len(text), textSize
' Clean up (very important to avoid memory leaks!) DeleteObject f DeleteObject tempBMP DeleteDC tempDC ' Return the measurements GetLabelSize = textSize
End Function
今回使うのは関数 GetStringPixelWidth だけです。次のとおり引数を渡すと、文字列の幅をピクセルで返してくれます。
GetStringPixelWidth ( [幅を調べたい文字列], [フォント名], [フォントサイズ], [太字か否か], [イタリックか否か])
メインのコードは下記の通りです。例外処理などは施してないです。開始行を選択した状態でマクロを実行してください。
Sub justifyToMergedRows()
'クリップボードからテキストを取得 Dim clipBoard As New DataObject clipBoard.GetFromClipboard Dim tgtString As Variant: tgtString = clipBoard.GetText
'改行コードを取り除く tgtString = Replace(tgtString, vbLf, "") Dim keyRng As Range: Set keyRng = Selection
'列幅（pixel）を取得し、pointに変換 Dim myPoints As Double: myPoints = getColumnWidth(keyRng) Dim columWidth As Double: columnWidth = WorksheetFunction.RoundUp(myPoints * 1.3, 1)
Dim str As String Dim stringWidth As Double Dim rowIndex As Long Dim charIndex As Long: charIndex = 1 Dim fontName As String: fontName = keyRng.font.Name Dim fontSize As Single: fontSize = keyRng.font.SIZE Dim currentRng As Range: Set currentRng = keyRng For charIndex = 1 To Len(tgtString) '対象テキストを一文字ずつ検査する If stringWidth < columnWidth Then '文字列の幅が列幅より小さいとき '現在の文字を文字列に結合 str = str & Mid(tgtString, charIndex, 1) Else '文字列の幅が列幅より大きいとき（つまりその行に入れる文字列が決定したとき） currentRng.Value = str '現在の行に文字列を入れる rowIndex = rowIndex + 1 '次の行に移動して、フォントとサイズを取得 Set currentRng = keyRng.Offset(rowIndex, 0) fontName = currentRng.font.Name fontSize = currentRng.font.SIZE str = Mid(tgtString, charIndex, 1) 'はみ出た1文字を取得しなおし、幅を取得 End If '文字列の幅を取得 stringWidth = _ GetStringPixelWidth(str, fontName, fontSize, False, False) Next '最後の一行を入れる Set currentRng = keyRng.Offset(rowIndex, 0) currentRng.Value = str End Sub
'結合セル一列の全体の幅を求める Function getColumnWidth(targetRange As Range) As Double Dim cCount As Long Dim colWidth As Double Dim colIndex As Long With targetRange cCount = .Columns.Count For cntIndex = 1 To cCount colWidth = colWidth + .Cells(1, cntIndex).Width Debug.Print .Cells(1, cntIndex).Width Next End With getColumnWidth = colWidth End Function
