結合セルを含めた並び替え

前提・実現したいこと

毎度お世話になっています。個数を反映した符号リストを作っているものです。

符号のある列をキーとした並び替えのコードを作成しているのですが、
その際、一定数を超えた番号セル列に対し結合を行っているので結合セルも同時に並び替えるために
「自分より1つ前の相手符号のほうが大きければ並び替える」という条件の処理で
一度結合セルを解除してから並び替え、行セルを挿入してもう一度結合する方法をとりました。

しかしどの符号よりも値が小さい符号が入力されると結合が解除されたまま並び替えられた状態になるなど、うまく働きません。
再結合させるFor文が自分の入力したセルにしか働かないのが原因なのですが、それ以外のセルをどう指定すればよいのか、
どのように処理すればよいのかが分かりません
詳しい方、お時間があればどうかご教授お願いします。

該当のソースコード

VBA
1Private Sub Worksheet_Change(ByVal Target As Range)
2
3    Dim SearchRange As Range
4    Dim ResultRange As Range
5    Dim KeyItem     As String
6    Dim ResultNumber As String
7    Dim i as Integer
8    Dim ResultValue As Long, Num As Long
9    Dim Rng As Variant
10    Set SearchRange = Range("A2:A100")  '探す符号の範囲
11
12With Target
13If Target.Count > 1 Then Exit Sub
14If .Column = 4 And .Row >= 2 And .Value <> "" Then    'D列2行目をクリックしたときに以下のマクロが動く
15
16    Application.EnableEvents = False
17
18    If .Value <> "" Then
19        .Value = "(" & .Offset(0, -1).Value & ")" & .Value
20
21        KeyItem = .Offset(0, -3).Value '符号をキーにして探す
22
23        For Each Rng In SearchRange     'SearchRangeのセル範囲をRngに代入して処理を繰り返す
24
25            If Rng = KeyItem And Rng.Row <> Target.Row Then     'RngがKeyItemのセル中身と一致し、異なる行を選んだ
26
27                ResultNumber = Rng.Offset(0, 3) & "," & Target.Value  '番号を入れる
28                ResultValue = Rng.Offset(0, 2) + Target.Offset(0, -1).Value  '個数を足す
29                Rng.Offset(0, 2) = ResultValue
30                Rng.Offset(0, 3) = ResultNumber
31                
32                Target.Offset(0, -3).Resize(1, 4).ClearContents '選んだセルの範囲の1行3列をクリア
33            
34                Num = Len(Rng.Offset(0, 3))
35                If Num Mod 20 <= 6 Then '番号を入れたセルが20の倍数で、6文字以上の時
36                    Rows(Rng.Row).Insert            '行挿入
37                    Application.DisplayAlerts = False
38                    
39                    Rng.Offset(-1, 0) = Rng.Offset(0, 0)              'それぞれ一行上に値を挿入してからMerge
40                    Rng.Offset(-1, 2) = Rng.Offset(0, 2)
41                    Rng.Offset(-1, 3) = Rng.Offset(0, 3)
42                    
43                    Rng.Offset(-1, 0).Resize(2).Merge          'ずらした行+元の行で2行のセルと結合
44                    Rng.Offset(-1, 2).Resize(2).Merge
45                    Rng.Offset(-1, 3).Resize(2).Merge
46                    
47                    Application.DisplayAlerts = True
48                End If
49
50                Exit For
51            End If
52            
53            '並べ替え部分
54                If Rng.Offset(0, 0) < Rng.Offset(-1, 0) Then
55                
56                    Range("A2:D100").UnMerge
57                    
58                        Range("A2:D100").Sort _
59                        Key1:=Range("A2"), _
60                        Order1:=xlAscending
61                                       
62                   Num2 = Len(Rng.Offset(-1, 3))
63                   For i = Num2 / 20 To Num2 < 20
64                     
65                      Application.DisplayAlerts = False
66                        Rows(Rng.Row).Insert
67                        Rng.Offset(-1 - i, 0) = Rng.Offset(-1, 0) '符号を上のセルに
68                        Rng.Offset(-1 - i, 2) = Rng.Offset(-1, 2) '個数を上のセルに
69                        Rng.Offset(-1 - i, 3) = Rng.Offset(-1, 3) '番号を上のセルに
70                        
71                        Rng.Offset(-1, 0).Resize(1 + i).Merge
72                        Rng.Offset(-1, 2).Resize(1 + i).Merge
73                        Rng.Offset(-1, 3).Resize(1 + i).Merge
74                
75                         Application.DisplayAlerts = True
76                    Next i
77                End If
78            
79            
80        Next
81    End If
82End If
83End With
84
85Application.EnableEvents = True
86End Sub

補足情報（FW/ツールのバージョンなど）

Excel2013を使用

行動規範の内容に同意します

回答2件

自己解決

整理作業と並び替えを一緒にしていたのが原因のようです。
整理の後に並び替え作業となるよう入れ替えました。
ご迷惑おかけして申し訳ありません。

VBA
1Private Sub Worksheet_Change(ByVal Target As Range)
2
3    Dim SearchRange As Range
4    Dim ResultRange As Range
5    Dim KeyItem     As String
6    Dim ResultNumber As String
7    Dim i As Integer, j As Integer, x As Integer
8    Dim ResultValue As Long, Num As Long, Num2 As Long
9    Dim Rng As Variant, Rng2 As Variant
10    Set SearchRange = Range("A2:A100")  '探す符号の範囲
11    Set SearchRange2 = Range("B2:B100")  '探す符号の範囲
12
13With Target
14
15If Target.Count > 1 Then Exit Sub
16If .Column = 4 And .Row >= 2 And .Value <> "" Then    'D列2行目をクリックしたときに以下のマクロが動く
17
18    Application.EnableEvents = False
19
20    If .Value <> "" Then
21        .Value = "(" & .Offset(0, -1).Value & ")" & .Value
22        
23'   符号の作業
24    If .Offset(0, -3) <> "" And .Offset(0, -2) = "" Then
25        KeyItem = .Offset(0, -3).Value '符号をキーにして探す
26        For Each Rng In SearchRange     'SearchRangeのセル範囲をRngに代入して処理を繰り返す
27
28            If Rng = KeyItem And Rng.Row <> Target.Row Then     'RngがKeyItemのセル中身と一致し、異なる行を選んだ
29
30                ResultNumber = Rng.Offset(0, 3) & "," & Target.Value  '番号を入れる
31                ResultValue = Rng.Offset(0, 2) + Target.Offset(0, -1).Value  '個数を足す
32                Rng.Offset(0, 2) = ResultValue
33                Rng.Offset(0, 3) = ResultNumber
34                
35                Target.Offset(0, -3).Resize(1, 4).ClearContents '選んだセルの範囲の1行3列をクリア
36            
37                Exit For
38                End If
39        Next
40        
41'符号以外の整理作業
42    ElseIf .Offset(0, -3) = "" And .Offset(0, -2) <> "" Then
43        KeyItem = .Offset(0, -2).Value
44             For Each Rng2 In SearchRange2
45              If Rng2 = KeyItem And Rng2.Row <> Target.Row Then     'RngがKeyItemのセル中身と一致し、異なる行を選んだ
46
47                ResultNumber = Rng2.Offset(0, 2) & "," & Target.Value  '番号を入れる
48                ResultValue = Rng2.Offset(0, 1) + Target.Offset(0, -1).Value  '個数を足す
49                Rng2.Offset(0, 1) = ResultValue
50                Rng2.Offset(0, 2) = ResultNumber
51                
52                Target.Offset(0, -3).Resize(1, 4).ClearContents '選んだセルの範囲の1行3列をクリア
53            
54                Exit For
55            End If
56            Next
57      Else
58      End If
59
60'並び替え
61                        Range("A2:D100").UnMerge
62                        Range("A2:D100").Sort _
63                        Key1:=Range("A2"), _
64                        Order1:=xlAscending
65                   For i = 100 To 2 Step -1  'セルの行指定
66                    Num = Len(Cells(i, 4))
67                     If Num > 20 Then
68                       j = Int(Num / 20)
69                    For x = 1 To j
70                        Rows(i).Insert
71                    Next x
72    
73                      Application.DisplayAlerts = False
74                        
75                        Cells(i, 1).Resize(j + 1).Merge
76                        Cells(i, 2).Resize(j + 1).Merge
77                        Cells(i, 3).Resize(j + 1).Merge
78                        Cells(i, 4).Resize(j + 1).Merge
79                
80                         Application.DisplayAlerts = True
81                   
82                    End If
83                  Next i
84                        
85    End If
86End If
87End With
88
89Application.EnableEvents = True
90End Sub