VBA Excel 連続していない行を複数行選択し、書式を変更したい

Question

【やりたいこと】
連続してない行を複数行選択し、一括で書式を変更したい

【詳細】
画像のようなテンプレートファイルを開き、accessで作成したデータを貼り付け
体裁を整えて別名にして保存するという処理で5ファイルほど同じように作成しています。

画像の4行までが書式のコピー元になる行です。
A列を配列(Arr)に格納し、For~Nextで該当する書式によって
同じ書式にしたい行をunionで配列(FormatCopy)に格納していき
最後に書式を貼り付けするという処理を行っています。

【エラー内容】
1ファイル目は問題なく作成(保存)されますが、2ファイル目の一番最初の
「Set FormatCopy(1) = Union(FormatCopy(1), .Cells(i, "A"))」でエラーになります。
＜実行時エラー '1004':
'Union'メソッドは失敗しました。 '_Global'オブジェクト＞

イミディエイトウィンドウで各変数を確認すると下記のようになっています。
FormatCopy(1) → A
.Cells(i, "A") → A
また、実行すると
＜実行時エラー '1004':
アプリケーション定義またはオブジェクト定義のエラーです。＞

【参考にしたURL】
参考にしたURL
findだと遅かったため配列にしました。

【環境】
win7 64bit office2010

Function Change_Format(ByRef xlApp As Excel.Application, ByRef ws As Excel.Worksheet) As Boolean

Dim Arr As Variant
Dim i As Long
Dim FormatCopy(1 To 4) As Variant

With ws
 Arr = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)     
 For i = 1 To 4
   Set FormatCopy(i) = .Cells(i, "A")
 Next i
        
 For i = 7 To UBound(Arr)
   DoEvents
   Select Case Arr(i, 1)
     Case "A"
        Set FormatCopy(1) = Union(FormatCopy(1), .Cells(i, "A"))
     Case "B"
        Set FormatCopy(2) = Union(FormatCopy(2), .Cells(i, "A"))
     Case "C"
        Set FormatCopy(3) = Union(FormatCopy(3), .Cells(i, "A"))
     Case "D"
        Set FormatCopy(4) = Union(FormatCopy(4), .Cells(i, "A"))
   End Select
 Next i

'書式を貼り付け
 For i = 1 To 4
    .Rows(i).Copy
     FormatCopy(i).EntireRow.PasteSpecial (xlPasteFormats)
 Next i
End With

End Function

Answer 1

外してたらすみません。

下記のYouTubeの動画解説（Office Tanakaさん）で、
VBAのオートフィルターを使用して、Ａ列などから特定の項目を絞り込んで
書式を一括して変更する、という例題を解説しています。

・【VBA】セルのOffsetプロパティとResizeプロパティを自在に使えるようになったら、
実務レベルのマクロでも困らない
https://www.youtube.com/watch?v=cbD1r2oojEk&t=7s

ちょっと長い動画なのですが、１４分目あたりから再生して
オートフィルターの解説が参考になるかチェックしてみてはいかがでしょうか？

Comments

[takamak]

autumn_nsnさん
ご回答ありがとうございます！
外してないです！！！ 14分からの動画とても参考になりました。
今から作り直してみてまたご報告いたします。

[takamak]

autumn_nsnさん
色々試してみました。

先ほどご回答いただきましたmattuwanさんへのご返事と同様に
実際は200列ほどあり、途中に空白列も存在します。
また、ところどろこグループ化もされているため、行ごとコピーして 行ごと貼り付けが望ましいのですが、それができませんでした。

A6セルに"書式"という文字を追加し下記のコードで実行しました。
Dim CopyArea As Range
Range("A6").AutoFilter 1, "A"
Set CopyArea = Range("A6").CurrentRegion.Offset(1, 0)
ws.Rows(1).Copy
CopyArea.Resize(CopyArea.Rows.Count - 1).EntireRow.PasteSpecial (xlPasteFormats)
Range("A6").AutoFilter

グループ化されている列がコピーされず、書式を貼り付けたときに歯抜けのような状態になってしまったり
グループ化をいったんすべて展開(手動で)してからコピペしてみたところ、オートフィルタが解除してしまったり･･･
苦戦しております。

Answer 2

autumn_nsnさん
mattuwanさん

貴重なヒントをくださりありがとうございました。
試行錯誤しエラーが出ずに実行できるようになりました。

今回実施したことをきちんと記載させていただきます。

＜やりたいこと＞
テンプレートファイルを開き、ACCESSで作成したデータを貼り付け、
A列の書式に該当する1～3行の行をコピーし一括で貼り付ける。
※わかりやすくするために、フォーマットの画像のA7～C16に文字が入力されていますがデータを貼り付ける前は何も入力されていません。

（補足）
・A7セル以降の書式はデータの最後まで必ず何かしらの文字が入っています
・書式をコピーした後に違う書式との間の罫線などは、後続処理で行っています

＜今回苦戦したこと＞
・unionで該当行のアドレスを結合し、一気に貼り付けを行ったところ 1ファイルは正しく作成されたが
2ファイル目作成時の最初のunionのところで"'Union'メソッドは失敗しました。 '_Global'オブジェクト"になってしまった。(最初のソース）
・CurrentRegionでは空白列/行があるとそれ以降が対象外となってしまったため使用できなかった
・グループ化されていると 複数行を一気に貼り付けるときにエラーとなった

ものすごく苦戦しましたが来上がってみれば貼り付けの処理自体は3行程度で済みました(^^;)

Function Main(ByRef xlApp As Excel.Application, ByRef ws As Excel.Worksheet)

　With ws
 　'フィルタが設定されている場合はいったん解除
 　If .AutoFilterMode = True Then .Rows(18).AutoFilter
 　'書式(行)コピーが正しく実行されないので、グループ化をすべて展開    
 　.Outline.ShowLevels ColumnLevels:=3                          
 　Call RowPaste(xlApp, ws, "A", 6, 1)
 　Call RowPaste(xlApp, ws, "B", 6, 2)
 　Call RowPaste(xlApp, ws, "C", 6, 3)
 　.Rows(18).AutoFilter                 'フィルタ解除
 　.Outline.ShowLevels ColumnLevels:=1  'グループ化の省略
　End With

End Function


Function RowPaste(ByRef xlApp As Excel.Application, ByRef ws As Excel.Worksheet, ByVal FindString As String, ByVal FindRow As Integer, ByVal CopyRow As Integer)

　With ws
　　'オートフィルタ実行
　　.Rows(FindRow).AutoFilter 1, FindString
　　'フィルタの結果がない場合もあるのでIF文で判定
　　If .Cells(.Rows.Count, 1).End(xlUp).Row <> FindRow Then
　　　.Rows(CopyRow).Copy
　　　'フィルタの結果が、フィルタ行の次の行の1件しかない場合にエラーになるための回避処理
　　　If FindRow + 1 = .Cells(.Rows.Count, 1).End(xlUp).Row Then      
　　　　.Rows(FindRow + 1).SpecialCells(xlCellTypeVisible).EntireRow.PasteSpecial (xlPasteFormats)
　　　Else
　　　　.Range(.Range("A" & FindRow + 1), .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.PasteSpecial (xlPasteFormats)
　　　End If
　　End If
　End With

End Function

Answer 3

空白セルだと簡単に複数を検索できるので、
一旦、空白にして検索し書式を貼り付けてみました。
参考になれば。

Option Explicit

Sub test()
    Dim rngFormat As Excel.Range
    Dim rngData As Excel.Range
    
    With Excel.Application.Workbooks(1).Worksheets(1)
        Set rngFormat = .Range("A1").CurrentRegion.Resize(, 11)
        Set rngData = .Range("A7").CurrentRegion
    End With
    
    CopyFormat rngFormat, rngData
End Sub

Function CopyFormat(ByRef rngFormat As Excel.Range, _
                    ByRef rngData As Excel.Range) As Boolean
    Dim r As Range
    Dim sKey As String
    
    CopyFormat = True
    
    For Each r In rngFormat.Rows
        sKey = r.Cells(1).Value
        
        With rngData
            .Replace sKey, ""
            r.Copy
            On Error GoTo ErrHandler
            With .SpecialCells(xlCellTypeBlanks)
                .PasteSpecial xlPasteFormats
                .Value = sKey
            End With
            On Error GoTo 0
        End With
    Next
    Exit Function
    
ErrHandler:
    CopyFormat = False
    Resume Next
End Function

修正しました。

Option Explicit

Sub test()
    Dim rngFormat As Range
    Dim rngData As Range

    With Worksheets(1)
        Set rngFormat = .Range("A1").CurrentRegion.Resize(, 200)
        Set rngData = .Range("A7").CurrentRegion
    End With

    CopyFormat rngFormat, rngData
End Sub

Function CopyFormat(ByRef rngFormat As Range, _
                    ByRef rngData As Range) As Boolean
    Dim r As Range
    Dim sKey As String

    CopyFormat = True

    For Each r In rngFormat.Rows
        sKey = r.Cells(1).Value

        With rngData.Columns(1)
            .Replace sKey, ""
            r.Copy
            On Error GoTo ErrHandler
            With .SpecialCells(xlCellTypeBlanks)
                Intersect(.EntireRow, rngFormat.EntireColumn).PasteSpecial xlPasteFormats
                .Value = sKey
            End With
            On Error GoTo 0
        End With
    Next
    Exit Function

ErrHandler:
    CopyFormat = False
    Resume Next
End Function

オートフィルターでやってみました。

Sub SetTableShaping(ByRef ws As Worksheet)
    Dim rngfromat As Range
    Dim rngTable As Range
    Dim r As Range
    
    With ws
        Set rngfromat = .Range("A1:AH3")
        Set rngTable = .Range(.Range("A7"), .Cells(.Rows.Count, "A").End(xlUp)) _
                        .Resize(, rngfromat.Columns.Count)
    End With
    
    ws.Outline.ShowLevels ColumnLevels:=3
    For Each r In rngfromat.Rows
        Copy2Format r, rngTable
    Next
    ws.Outline.ShowLevels ColumnLevels:=1
End Sub

Private Sub Copy2Format(ByRef prngformat As Range, ByRef prngTable As Range)
    With prngTable
        .AutoFilter 1, prngformat.Cells(1).Value
    
        If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            prngformat.Copy
            Intersect(.Cells, .Offset(1)).PasteSpecial xlPasteFormats
        End With
    
        .AutoFilter
    End With
End Sub

小計行と合計行に色を付けるのがテーマなら、
ABCをあえて入力しなくても、
他のやり方もありそうですが、
もう、おなかいっぱいでしょうね。

Comments

[takamak]

mattuwanさん
ご回答ありがとうございます。
早速試してみました。
が、説明不足で申し訳ございません。
画像はサンプルのためシンプルにしましたが、実際は200列ほどあり
途中に空白列も存在します。
また、ところどろこグループ化もされているため、
行ごとコピーして 行ごと貼り付けが望ましいのですが、それができません。
CurrentRegionでは 空白行や空白列がある場合 難しいですよね？？

[mattuwan]

＞CurrentRegionでは 空白行や空白列がある場合 難しいですよね？？
んー今回の件の場合は、結局「1列目」が判断の対象になるので、
1列目に空白セルがなければ、特に問題にならないでしょう。

＞また、ところどろこグループ化もされているため、
グループ化とコピペとがどう影響するのか、
実際のシートで試さないと何とも言えませんが、
直感的には特に関係ないかと思ってます。

提示のコードは少し雑でしたので、も少し丁寧に書いて追記してみます。