[VBA]他の行の最終行に合わせてセルの書式を結合したい

Question

前提・実現したいこと

図のように、別のエクセルファイルから持ってきたデータを一覧にするファイルを作成しています。

例１：

この図を下記のように、
A行を別の列の最終行までセルの結合させたいです。

例２：

MaxRowを使ってMergeするのかな？と思ったのですが、
どうやれば良いのか分からず、、お力添え頂けると幸いです…

コピー元(セルの結合を全て解除して使用します)：

ソースコード

Option Explicit

Sub import_excel()
    
    '最終行を変数に取得
    Dim MaxRow As Integer
    MaxRow = Worksheets("2019年10月").Cells(Rows.Count, 1).End(xlUp).Row + 2
    
    Dim arrayPath As Variant
    arrayPath = Application.GetOpenFilename("ブック, *.xlsm", MultiSelect:=True)
             
  If IsArray(arrayPath) Then
        
    MsgBox "ちょっと時間かかるかも(´;ω;｀)"
    
    '画面の描画を停止する
    Application.ScreenUpdating = False
        
    'Forループ(iが1から配列の要素数まで)
    Dim i As Integer
    For i = 1 To UBound(arrayPath)
            
    '変数を用意し、ブックを開いて格納
    Dim openBook As Workbook
    Set openBook = Workbooks.Open(arrayPath(i))
            
    'セルの結合を解除する
    Cells.Select
    Selection.UnMerge
    
     With Workbooks("管理表VBA").Worksheets("2019年10月")
        .Range("A" & MaxRow).Value = openBook.Worksheets(1).Range("E6").Value
    
    Call RgCopy(.Range("B" & MaxRow), openBook.Worksheets(1).Range("AA9:AA14"))
    Call RgCopy(.Range("D" & MaxRow), openBook.Worksheets(1).Range("S9:S14"))
         .Range("E" & MaxRow).Value = openBook.Worksheets(1).Range("AH15").Value
         .Range("F" & MaxRow).Value = openBook.Worksheets(1).Range("H8").Value
         .Range("G" & MaxRow).Value = openBook.Worksheets(1).Range("B4").Value

     End With

     Application.DisplayAlerts = False
     openBook.Close

     MaxRow = MaxRow + 2
     
     Next i

    '画面の描画を再開する
     Application.ScreenUpdating = True
        
    MsgBox "おわたよ(｀・ω・´)"
             
  End If
End Sub

'fromRg：コピー元セル
'toRg：コピー先セル
Private Sub RgCopy(toRg As Range, fromRg As Range)
    Dim rg As Range
    Dim i As Long
    i = 0
    For Each rg In fromRg
        If rg.Value <> "" Then
            toRg.Offset(i).Value = rg.Value
            i = i + 1
        End If
    Next
End Sub

ツールのバージョン

Excel 2016

追記(19/10/15)

イメージ図をもっとわかりやすいものに変更しました。

Comments

[kaputaros]

読み取る他のファイルのデータがどのようなものか、も提示したほうがいい回答が得られるかと思います～

Answer 1

セル結合することが目的でないのであれば、条件付き書式で「セルの値が"" なら上罫線を消す」というのはどうでしょう。
ループが無いので処理速度は速いです。

条件付き書式の設定方法の説明がむつかしいので、VBAで設定するコードを以下に記載します。

    Dim maxRow As Integer
    With Worksheets("2019年10月")
       
        ' B列を対象に最終行を求める
        maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    
        'A4～AXXの範囲で、セルの値が入っていないセルは、上罫線なしにする。
        With .Range("A4:A" & maxRow)
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$A4="""""
            Dim idx
            idx = .FormatConditions.Count
            .FormatConditions(idx).SetFirstPriority
            .FormatConditions(idx).Borders(xlTop).LineStyle = xlNone
            .FormatConditions(idx).StopIfTrue = False
        End With
    End With

Comments

[Jonny_dayo]

回答ありがとうございます！！
こんな方法もあるんですねっ！勉強になります。。
ただ今回はセルの結合を目的としているため、別の機会でこの方法も試してみようと思います！

Answer 2

表の1列目の空白部分を、その1行上から含めて結合したい。
ということですよね？

その作業の流れをVBA語にしたら、こんな感じになると思います。

Sub test()
    Dim rngTable As Range
    Dim a As Range

    '表の範囲の取得
    With Workbooks(1).Worksheets(1).Range("A1").CurrentRegion
        Set rngTable = Intersect(.Cells, .Offset(2))
    End With
    '表の1列目の空白セルの塊を順次みていく
    For Each a In rngTable.Columns(1).SpecialCells(xlCellTypeBlanks).Areas
        '1行上のセル範囲を含めて結合
        Application.Range(a, a.Offset(-1)).Merge
    Next
End Sub

ブック名、シート名はそちらの環境に合わせて変更ください。

提示のコード、
セル範囲を変数に入れると、コードがすっきりすると思います。

Comments

[Jonny_dayo]

回答ありがとうございます！
環境に合わせて入れてみたところ、「アプリケーション定義、またはオブジェクト定義のエラーです」と出てしまいました。。つまりこれは環境に合わせ切れていないということでしょうか…？

Answer 3

他のファイルからデータを貼り付ける際にレコード数をカウントして、
最後にカウントした数を考慮してmargeすればいいのでは？
というのも、
列は要素が固定ですが、行は可変なので、
列で考えるより、行で考えたほうがいいかと思います。
（Rangeの指定も定数固定になっているので、もう少し汎用的にできるといいかも。。。）

【VBA入門】Rangeでセルの範囲指定(Cellsとの使い分けも解説)

---

Rangeはコピー先の指定が定数固定になってるってことでしょうか？奥が深い…

～.Range("AA9:AA14")
など、
"AA9:AA14"
と定数で指定しているので、固定になりますよね。
ここに必ず欲しいデータがあって、そこだけしか要らない場合には有効ですが、そうでない場合は、
"AA"&[変数1]&":AA"&&[変数2](変数のところは適宜変えてください)
にして変数のところが可変にすれば、データが少なくても多くても対応できますよね。
他にもいろいろやり方はあると思います。

あと、どのようなデータが入っているのかわかり得ませんが、
ファイルの読み込みは一度にしてしまったほうがいいですよ。
外部データのIOは時間や負荷がかかりやすし、
全てのデータを読み込んでしまってからまとめて処理したほうが、効率がいいことが多いです。
（仕様によってはそうできないものもありますが）

箇条書きでもいいので、どんな処理フローにしたいか、まとめてからコーディングするといいですよ。

Comments

[Jonny_dayo]

回答ありがとうございます！
一番汎用性が効きそうな方法ですね！調べてみたところ、DAOやらDcount関数など出てきました。
これで指定した列のデータをカウントしてマージする感じですかね…？(難しそう…)
Rangeはコピー先の指定が定数固定になってるってことでしょうか？奥が深い…

[kaputaros]

いやいや、DAOはデータベースを扱うときにはつかうだろうけど、
ワークシート上での作業だったら別に使わなくてもいいかと思いますよ。
（勉強のためにつかって色々してみてもいいとは思うけど、目先の問題を解決してからで遅くないかと、、。）

回答に追記しました。

[Jonny_dayo]

追記及び諸々ご丁寧にありがとうございます！
今回は必ずほしいデータのセルが決まっているのでこのままにさせていただこうと思いますが、たくさん他のやり方を教えて頂けたので次回以降色々試してみようと思います！！！
読み取る先のデータ画像も追記させて頂きました！
今回はファイルを複数選択する
↓
コピー先へ転記する
↓
A列のセル結合などレイアウトを整える
↓
2枚目のファイルを処理する
というループ処理をさせています。
(私の中では…もしなってなかったらすみません)

Answer 4

A列の切り替わり、もしくはB列の最終行でA列を結合するサンプルです。
お試しください。

Dim sh As Worksheet
Dim sr As Long
Dim er As Long

Set sh = Worksheets("2019年10月")
sr = 2
er = 2
Do
    If ((sh.Cells(er, 1).Value <> "" And sh.Cells(er, 2) <> "") Or (sh.Cells(er, 2) = "")) And er <> 2 Then
        sh.Range(sh.Cells(sr, 1), sh.Cells(er - 1, 1)).Merge
        If sh.Cells(er, 2) = "" Then Exit Do
        sr = er
    End If
    er = er + 1
Loop

Comments

[Jonny_dayo]

回答ありがとうございます！
早速試してみたのですが、マージされず…(なぜでしょうか…)
Worksheets("2019年10月")部分をそのままにしてみたり、Workbooks("管理表VBA").Worksheets("2019年10月")にしてみたりとしたのですが、、
B列の最終行でA列を結合できたら最高なんですけど…

[ttyp03]

しまった。データは3行目からでしたね。
最初のsrとerの値を3にしてみてください。

[Jonny_dayo]

ご丁寧にありがとうございます！
データは4行目からなので、4にして実行してみたところ結合はされたのですが、後からデータを追加していっても既に結合されたセルがどんどん大きくなっていってしまいます。。

[ttyp03]

いやぁ、そんな仕様聞いてないっすわ。
しかも表のフォーマット変わってないすか？
あとはご自分で修正よろしく！

[Jonny_dayo]

ですよねー、、すみません！
お忙しいところありがとうございました！