Excel VBA

Ａ列の何個かのセルをＢ1セルで一つにして書式を反映させるVBA

タイトル通りです。
Ａセルの文字ごとに設定されている書式を、B1セルに反映させます。
（VBAは1回動作させると、元に戻せません。試される場合は、1回保存するなど、
やり直しのきく状態にしていただくことを強くおすすめします。）

Ａ列のセルに文字が入っていて、それぞれに文字単位で書式が設定されている。Ｂ1セルにそれをまとめて、かつＡ列の書式を反映している

クラスを使いますが、大したことないですので、ご安心ください。

右クリックでクラスモジュールを新規で作っていただき、
オブジェクト名を「文字書式データ」に変更してください。
クラス内に以下のコードを貼り付けてください。

 Option Explicit
    
  Public 文字書式 As String
  Public 文字 As String
  Public 文字数 As Long
  Public フォント名 As String
  Public 文字の大きさ As String
  Public 下線 As long
  Public 太さ As String
  Public 斜め As String
  Public 色 As String

以下は、標準モジュールに記入してください。

Sub くっつけたセルに文字書式を反映させる()
   
    Dim 文字 As 文字書式データ
    
    Dim 文字書式 As Collection
    Set 文字書式 = New Collection
    
    Dim j As Long, cnt As Long
    j = 1
    cnt = 0
    
    Dim last_row As Long
    last_row = Cells(Rows.Count, 1).End(xlUp).Row
    
    'B1セルに結合して一つにした文字を入れる。
    '改行をvbLfにしないと、ダブルクリックして編集する時おかしなことになるので、vbCrLfでなくvbLfにしています。
    '空白行を無視する場合には下記～vbLf, 「1」をそのまま、無視しない場合は「0」に変更してください。
    Range("B1") = WorksheetFunction.TextJoin(vbLf, 1, Range(Range("A1"), Cells(last_row, 1)))
    
    '最後に改行をいれたいため追加しました。必要なければコメントアウトしてください。
    If Right(Range("B1"), 1) <> vbLf Then Range("B1").Value = Range("B1").Value & vbLf
    
    Dim i As Long, k As Long
    For k = 1 To last_row

        For i = 1 To Len(Cells(k, 1))
            cnt = cnt + 1
            
            Dim tmp As String
            tmp = Mid(Cells(k, 1), i, 1)

           If tmp = Chr(13) Or tmp = Chr(10) Then
            'Debug.Print tmp
           Else
            Set 文字 = New 文字書式データ
             With Cells(k, 1).Characters(i, 1).Font
                 文字.文字数 = cnt
                 文字.フォント名 = .Name
                 文字.文字の大きさ = .Size
                 文字.下線 = .Underline
                 文字.太さ = .Bold
                 文字.斜め = .Italic
                 文字.色 = .Color
             End With
             文字書式.Add 文字
            Set 文字 = Nothing
            End If
            j = j + 1
        Next i
    Next k
    
    Dim next_cnt As Long
    next_cnt = 1
    For i = 1 To Len(Cells(1, 2))
       tmp = Mid(Cells(1, 2), i, 1)
       If tmp = vbCrLf Or tmp = vbLf Or tmp = vbCr Or tmp = Chr(13) Or tmp = Chr(10) Then
        'Debug.Print tmp
       Else
          With Cells(1, 2).Characters(i, 1).Font
            On Error Resume Next
            .Name = 文字書式.Item(next_cnt).フォント名
            .Size = 文字書式.Item(next_cnt).文字の大きさ
            .Underline = 文字書式.Item(next_cnt).下線
            .Bold = 文字書式.Item(next_cnt).太さ
            .Italic = 文字書式.Item(next_cnt).斜め
            .Color = 文字書式.Item(next_cnt).色
          End With
          next_cnt = next_cnt + 1
        End If
    Next i
   
   Set 文字書式 = Nothing
   
   Range("B1").Copy
   Worksheets("貼り付け用").Range("A1").PasteSpecial
   
   MsgBox "終わります"
End Sub

はじめてクラスを使いましたが、中々便利です。
まだまだですが、少しずつ応用が利くように勉強していきたいです。

記事は以上になります。

最後になりましたが、お読みくださった方、ありがとうございました！

おすすめの記事