[Excel VBA] 結合セルにコピーペーストするマクロ

Feb 13, 2021 · この記事は約5分で読めます · Excel VBA 自作 ·

Share on:

概要

この記事について

Excelにおいて
通常セルから結合セルに対してコピーすると、
「結合セルにこの操作は行えません」という警告がされ貼り付けができない。

例えば下記画像の12列の「西川～竹田」を
表のname列に貼り付けしようとしてもエラーとなる。

貼り付けエラー01

貼り付けエラー02

これを回避するには、
コピー元セルも同じ結合様式にする（コピー先が2行3列の結合セルならば元のセルも2行3列にする）、
あるいは VBAマクロにより機能を追加する他には方法がなさそうなので、
マクロを作成することにした。

作成環境

windows10
MSOffice 2016

要件

コピーしたいセル（コピー元）をクリップボードにコピーしたあとに実行して、
選択中のセル（コピー先）に貼り付けしたい。

コピー元、コピー先ともに、どのような結合様式でも貼り付けできるようにする。

結合セルを取り込む際に、
結合している左上のセル以外は空欄であるため、
空欄のみの部分は除外できるようにしたい。

処理フロー

コード

「結合セルにコピー」Subプロシージャ

  1'******************************************************************************************
  2'*機能      ：結合セルにコピーする
  3'               コピー元は通常セルでも結合セルでも可
  4'*引数      ：
  5'******************************************************************************************
  6Public Sub 結合セルにコピー()
  7    
  8    '定数
  9    Const FUNC_NAME As String = "結合セルにコピー"
 10    
 11    '変数
 12    Dim arr() As Variant
 13    Dim row As Long: row = 0
 14    Dim col As Long: col = 1
 15    Dim dicIgnoreRow As Object: Set dicIgnoreRow = CreateObject("Scripting.Dictionary")
 16    Dim dicIgnoreCol As Object: Set dicIgnoreCol = CreateObject("Scripting.Dictionary")
 17    
 18    On Error GoTo ErrorHandler
 19        
 20    'テキスト形式であるかチェック
 21    If Application.ClipboardFormats(1) <> xlClipboardFormatText Then MsgBox "クリップボードのデータがテキストではありません。", vbExclamation, FUNC_NAME: GoTo ExitHandler
 22        
 23    '1 - クリップボードから配列にデータを移す
 24    '       vbNewLineを行区切り、
 25    '       vbTabを列区切りとして、
 26    '       二次元配列に格納する
 27    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
 28        
 29        .GetFromClipboard
 30        Dim c, d
 31        ReDim arr(1 To 1, 1 To 1)
 32        For Each c In Split(.GetText, vbNewLine)
 33            row = row + 1
 34            If row > 1 Then arr = redimPreserveFor1stDimension(arr, row)
 35            'currentCol:現在格納の対象とする列インデックス
 36            Dim currentCol As Long: currentCol = 0
 37            For Each d In Split(c, vbTab)
 38                currentCol = currentCol + 1
 39                If currentCol > col Then
 40                    col = col + 1
 41                    ReDim Preserve arr(1 To row, 1 To col)
 42                End If
 43                arr(row, currentCol) = Trim(d)
 44            Next d
 45        Next c
 46    End With
 47    
 48    '2 - 空欄のみの行、空欄のみの列を記録し、
 49    '貼り付けする際に除外する
 50    
 51    '行の除外チェック
 52    Dim i, j As Long
 53    Dim isIgnore As Boolean
 54    For i = 1 To UBound(arr)
 55        isIgnore = True
 56        For j = 1 To UBound(arr, 2)
 57            '対象要素が空欄でなければその行は貼り付けから除外しない
 58            If Trim(arr(i, j)) <> "" Then isIgnore = False: Exit For
 59        Next j
 60        If isIgnore Then dicIgnoreRow.Add i, True
 61    Next i
 62    '列の除外チェック
 63    For j = 1 To UBound(arr, 2)
 64        isIgnore = True
 65        For i = 1 To UBound(arr)
 66            '対象要素が空欄でなければその列は貼り付けから除外しない
 67            If Trim(arr(i, j)) <> "" Then isIgnore = False: Exit For
 68        Next i
 69        If isIgnore Then dicIgnoreCol.Add j, True
 70    Next j
 71    
 72    '3 - 選択しているセルを起点として配列を貼付する
 73    Dim k, l As Long
 74    Dim r, tmp As Range
 75    Set r = Selection(1)
 76    For k = 1 To UBound(arr): Do
 77        '除外する行ならばcontinueする
 78        If dicIgnoreRow.exists(k) Then Exit Do
 79        '現在のアドレスの範囲を保持
 80        Set tmp = r
 81        
 82        For l = 1 To UBound(arr, 2): Do
 83            '除外する列ならばcontinueする
 84            If dicIgnoreCol.exists(l) Then Exit Do
 85            '貼り付け
 86            r.Value = arr(k, l)
 87            '貼り付け先を一つ右の列に移す
 88            Set r = r.Offset(, 1)
 89        Loop While False: Next l
 90        '貼り付け先を一つ下の行に移す
 91        Set r = tmp.Offset(1)
 92    Loop While False: Next k
 93    
 94    Application.CutCopyMode = False
 95    
 96ExitHandler:
 97
 98    Exit Sub
 99    
100ErrorHandler:
101
102    MsgBox "エラーが発生したため、マクロを終了します。" & _
103           vbLf & _
104           "関数名：" & FUNC_NAME & _
105           vbLf & _
106           "エラー番号：" & Err.Number & vbNewLine & _
107           Err.Description, vbCritical, "マクロ"
108        
109    GoTo ExitHandler
110        
111End Sub
112

「redimPreserveFor1stDimension」Functionプロシージャ

 1'******************************************************************************************
 2'*機能      ：Redim Preserveステートメントの拡張
 3'               通常、二次元配列に対して
 4'               Redim Preserveステートメントは1次元目の要素数を変更できないため、
 5'               この関数を代わりに用いる
 6'*引数      ：対象配列
 7'*引数      ：一次元目の要素数の上限
 8'*戻り値    ：True > 正常終了、False > 異常終了
 9'******************************************************************************************
10Private Function redimPreserveFor1stDimension(ByVal arr As Variant, ByVal sLen As Long) As Variant
11    
12    '定数
13    Const FUNC_NAME As String = "redimPreserveFor1stDimension"
14    
15    '変数
16    Dim tspsedArr As Variant
17        
18    On Error Resume Next
19    
20    'transposeにより対象配列を転置
21    tspsedArr = WorksheetFunction.Transpose(arr)
22    '二次元目を引数の長さまでRedimする（- A）
23    ReDim Preserve tspsedArr(1 To UBound(tspsedArr, 1), 1 To sLen)
24
25    redimPreserveFor1stDimension = WorksheetFunction.Transpose(tspsedArr)
26    
27    '(1 * N)行列を転置すると二次元目が消えて一次元の配列になるため、
28    '（- A）の箇所でエラーになる
29    'その場合は代わりに下記のように処理を行う
30    If Err.Number = 9 Then
31        Dim newArr As Variant
32        Dim i As Long
33        Err.Clear
34        On Error GoTo ErrorHandler
35        ReDim newArr(1 To UBound(arr, 1) + 1, 1 To 1)
36        '既存の値を反映する
37        For i = 1 To UBound(arr, 1)
38            newArr(i, 1) = arr(i, 1)
39        Next i
40        redimPreserveFor1stDimension = newArr
41    End If
42    
43ExitHandler:
44
45    Exit Function
46    
47ErrorHandler:
48
49    MsgBox "エラーが発生したため、マクロを終了します。" & _
50           vbLf & _
51           "関数名：" & FUNC_NAME & _
52           vbLf & _
53           "エラー番号：" & Err.Number & vbNewLine & _
54           Err.Description, vbCritical, "マクロ"
55        
56    GoTo ExitHandler
57        
58End Function