エクセルで同じ数字同士を自動で線で結ぶVBAを教えてください

画像のように、行の数字同士をセルの中央で自動で線を結ぶ方法を教えてください。以前、列での同じ数字の例がありましたので、それを行で真似をしてみましたが、うまくいきません。よろしくお願いします。ちなみに下記のようにしたのですが、、、
Sub test()
Range("B9:S11").HorizontalAlignment = xlCenter '中央寄せ
Range("B9:S11") = "=Randbetween(1,18)" '乱数の生成
ActiveSheet.Shapes.SelectAll '既存の図形を選択
Selection.Delete '既存の図形を削除
Dim i As Long, j As Long
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
For i = 1 To 18 '9行の値の個数分だけ繰り返す
For j = 1 To 18 '一つの9行の値で11行全部を照合
If Cells(i, 1) = Cells(j2) Then '9行の数値と11行の数値が同じなら
x1 = Cells(i, 1).Left + Cells(i, 1).Width / 2 '直線の引き始めの横位置
y1 = Cells(i, 1).Top + Cells(i, 1).Height / 2 '直線の引き始めの縦位置
x2 = Cells(j, 2).Left + Cells(j, 2).Width / 2 '直線の引き終わりの横位置
y2 = Cells(j, 2).Top + Cells(j, 2).Height / 2 '直線の引き終わりの縦位置
ActiveSheet.Shapes.AddLinex1 , y1, x2, y2 '線を引く
End If
Next
Next
End Sub

No.6 回答者： Qchan1962 回答日時： 2022/04/27 14:48

＞線を赤くしたいのですが、ForeColor.ObjectThemecolor = msoThemeColorAccent2

テーマカラーで設定されたいのでしょうか？こちらでは分り兼ねますが

赤い線を作る場合、AddLineの書き方を少し変えて
ActiveSheet.Shapes.AddLine x1, y1, x2, y2 ' 線を引く
を下記のようにします

With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Line ' 線を引く
.ForeColor.RGB = vbRed
.Weight = 0.8
End With

Withで括り、線種や太さも変更できます（色と線の太さの例）

この回答へのお礼

Qchan１９６２様
お世話になり、誠に有難うございました。
全くの素人が本とかで見まねでは上手くいかないところをご迷惑おかけしました。いろいろと有難うございました。
ただ、いろいろ勉強不足なので、2つの要件のコードを1枚のシートに表示すると、片方だけしか機能しないこともわかりました。これをまたどうするかを勉強していきます。有難うございました。

お礼日時：2022/04/28 01:01

No.5 回答者： Qchan1962 回答日時： 2022/04/27 13:27

こんにちは

>データが変わったことを、私の能力ではどうすることも出来ません、、、そこをさらなるアドバイスを頂ければ幸いです

Range("B9:S11") = "=Randbetween(1,18)" '乱数の生成
で関数がセルに入力されていますので、上記1行を削除、
セルに残った数式が不要の場合、削除してみてください

この回答へのお礼

早速の対応有難うございました。
貴殿のご回答の通り、乱数の生成を削除したら、データーが変化してしまうこともなくなりました。もう一つ、おまけに教えてください。
線を赤くしたいのですが、ForeColor.ObjectThemecolor = msoThemeColorAccent2
としたのですが、これもまた機能しません。入力する場所なのか、そのものが良くないのか、教えていただければ幸いです。

お礼日時：2022/04/27 14:32

No.4 回答者： Qchan1962 回答日時： 2022/04/27 01:47

#3です

寝付きが悪くなりそうなので、追記しておきます
＃３のコードは、真似をするべきコードではありません
改めて見ても書いた本人が気に入りませんが仕方ありませんね
こんな書き方もあるのか程度で（悪い例として）流してください

No.3 回答者： Qchan1962 回答日時： 2022/04/27 01:20

＃１です

コードは参考にしたコードで添付図の上の部分C4：T7の範囲と言う事なのですね。
勘違いをしました。
＃２様が既に回答されていますが、一応　セル範囲を少し改造し易くしてみました

Sub test()
Dim criterion As Range, target As Range
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
Dim n As Long
Range("C4:T7").HorizontalAlignment = xlCenter '中央寄せ
'Range("C4:T7") = "=Randbetween(1,18)" '乱数の生成
ActiveSheet.Shapes.SelectAll '既存の図形を選択
Selection.Delete '既存の図形を削除
For n = 0 To Range("C4:T7").Rows.Count - 2
For Each criterion In Range("C4:T4") '
For Each target In Range("C5:T5")
If criterion.Offset(n).Value = target.Offset(n).Value Then '9行の数値と11行の数値が同じなら
x1 = criterion.Offset(n).Left + criterion.Offset(n).Width / 2 '直線の引き始めの横位置
y1 = criterion.Offset(n).Top + criterion.Offset(n).Height / 2 '直線の引き始めの縦位置
x2 = target.Offset(n).Left + target.Offset(n).Width / 2 '直線の引き終わりの横位置
y2 = target.Offset(n).Top + target.Offset(n).Height / 2 '直線の引き終わりの縦位置
ActiveSheet.Shapes.AddLine x1, y1, x2, y2 ' 線を引く
End If
Next
Next
Next n
End Sub

基準行１行の処理が終わると基準行と対象行が共に１行ずつ移動していくような処理です（1行目から3行目以降などとび行には線が引かれません）
移動回数は対象範囲の行の数で取得しています
もう少しまとめる事が出来ますが、内容が分かり難くなるかもしれないので
範囲を分けてみました

この回答へのお礼

Qchan1962様
有難うございます。勘違いではなく、最初の質問には２つの要件が本当はあったのですが、私が急いでいたので、文章作成能力の欠如と質問の図にも間違いがあり、ご迷惑をおかけしました。最初にご回答いただいたのであれは良かったのです。私が9行と11行と書いたため、さらに混乱を招いたと反省しております。実際は11行と13行の間違いでした。貴殿のご回答のように作成したのですが、1点問題がありまして、線は結ばれるのですが、元々の11行と13行のデータまで変わってしまい、、、これが無知の私にはどうしたら良いかわかりません。貴殿のご回答により線で結ばれたことに大変喜びを感じた次第ですが、データが変わったことを、私の能力ではどうすることも出来ません、、、そこをさらなるアドバイスを頂ければ幸いです。

お礼日時：2022/04/27 12:31

No.2 回答者： mygoonickname 回答日時： 2022/04/26 23:43

こんばんは。

4～7行に線を引くマクロを、質問者さんのマクロを元に作ってみました。
下記で、どうでしょうか？

Sub 同じ数字に線を引く()
Dim i As Long, j As Long, k As Long
ActiveSheet.Shapes.SelectAll '既存の図形を選択
Selection.Delete '既存の図形を削除
For k = 3 To 5
For i = 3 To 20 '9行の値の個数分だけ繰り返す
For j = 3 To 20 '一つの9行の値で11行全部を照合
If Cells(k, i).Value = Cells(k + 1, j).Value Then '9行の数値と11行の数値が同じなら
Call 線を引く(Cells(k, i), Cells(k + 1, j))
End If
Next j
Next i
Next k
End Sub

Sub 線を引く(myRng1 As Range, myRng2 As Range)
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single

x1 = myRng1.Left + myRng1.Width / 2 '直線の引き始めの横位置
y1 = myRng1.Top + myRng1.Height / 2 '直線の引き始めの縦位置
x2 = myRng2.Left + myRng2.Width / 2 '直線の引き終わりの横位置
y2 = myRng2.Top + myRng2.Height / 2 '直線の引き終わりの縦位置
ActiveSheet.Shapes.AddLine x1, y1, x2, y2 '線を引く
End Sub

この回答へのお礼

早速のご回答有難うございます。まだまだ素人の私ですが、これからもご指導よろしくお願いします。早速試してみたいと思います。

お礼日時：2022/04/27 00:25

No.1 回答者： Qchan1962 回答日時： 2022/04/26 23:42

こんばんは

Cellsの使い方がちょっと変です
'9行の値の個数分だけ繰り返す
'一つの9行の値で11行全部を照合
＞Range("B9:S11")
を参考に添削すると（10行目は取り敢えず無視しています）
Sub test()
Dim i As Long, j As Long
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
Range("B9:S11").HorizontalAlignment = xlCenter '中央寄せ
Range("B9:S11") = "=Randbetween(1,18)" '乱数の生成
ActiveSheet.Shapes.SelectAll '既存の図形を選択
Selection.Delete '既存の図形を削除
For i = 2 To 19 '9行の値の個数分だけ繰り返す
For j = 2 To 19 '一つの9行の値で11行全部を照合
If Cells(9, i) = Cells(11, j) Then '9行の数値と11行の数値が同じなら
x1 = Cells(9, i).Left + Cells(9, i).Width / 2 '直線の引き始めの横位置
y1 = Cells(9, i).Top + Cells(9, i).Height / 2 '直線の引き始めの縦位置
x2 = Cells(11, j).Left + Cells(11, j).Width / 2 '直線の引き終わりの横位置
y2 = Cells(11, j).Top + Cells(11, j).Height / 2 '直線の引き終わりの縦位置
ActiveSheet.Shapes.AddLine x1, y1, x2, y2 ' 線を引く
End If
Next
Next
End Sub

コード内の定数：
２はB列　19はS列
９は9行目　11は１１行目

この回答へのお礼

早速のご回答有難うございます。私は、本、人のまねをしてのまだ素人です。
ただ、10行を無視したというよりも、私の作成利用している表では1行空けているからです。それが問題であれば、その行をなくしたいと思います。
早速いまから、試してみたいと思います。

お礼日時：2022/04/27 00:24