こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

回答受付中の質問

Excel2007で複雑なセルコピペ。

sheet8のセル範囲C3からセルI10000までの各セルにA~Jのいずれかがランダムに入ってます。

マクロボタンをおします。

(1)、C12の値をM3にコピペしてC12から5行戻ったC7の値をセルO3にコピペします。

(2)、M3の値とO3の値が同じならM3の背景色を黄色にしたいです。同じでないならそのままです。

マクロボタンを押します。

(3)、1つ下のC13に行き(1)と同じことをするのですが、1つ下のM4にC13の値をコピペしてC13から7行戻ったC6の値をO4にコピペしたいです。

(4)、(2)と同じようになり
マクロボタンを押します

(5)、1つ下のC14に行き(1)と同じことをするのですが、1つ下のM4にC14の値をコピペしてC14から9行戻ったC5の値をO5にコピペしたいです。

(6)、(2)と同じようになります。
マクロボタンを押します。
End

マクロボタンを押す度にC12から1つずつ下に向かい、M3から1つずつ下に向かって値をコピペするのですが、セルOにコピペされるのは1つずつ下に向かうセルCの値から、5行戻り、7行戻り、9行戻りと戻ってはまた5行、7行、9行と戻った値を繰り返しコピペしたいです。

よろしくお願いいたします。

投稿日時 - 2019-06-27 07:17:05

QNo.9629507

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(21)

ANo.21

>「インデックス有効範囲エラー」がでました。

申し訳ありませんが
・[SetData]モジュールで変更した箇所とその値
・エラーが起こった時のi、j、kの値
を教えてください。

i、j、kは、エラーでストップした際、それぞれの変数の上にマウスカーソルを動かせば表示される筈です。
或いは右クリック-[ウォッチ式の追加]で、ウォッチウィンドウに表示させる方法もあります。

投稿日時 - 2019-07-22 09:14:34

ANo.20

>コンパイルエラーとなり修正候補はThen またはGo to
一応、No18,No19のコードをコピペして走らせてみましたが、こちらではエラーが起こりませんでした。
が、if分の最後のアンダーバーを削除してみたら、同様の「コンパイル エラー:修正候補: Then または GoTo」と出ました。
多分、その辺りで変な事になっていたのではないでしょうか。


以下の二行を
 If rangeCompare(1).Row + WorksheetFunction.Min(Rev.OffRow) <= 0 Or _
  rangeCompare(1).Column + WorksheetFunction.Min(Rev.OffCol) <= 0 Then

下の一行に変えて下さい。
If rangeCompare(1).Row + WorksheetFunction.Min(Rev.OffRow) <= 0 Or rangeCompare(1).Column + WorksheetFunction.Min(Rev.OffCol) <= 0 Then

アンダーバーと改行を削除する感じです。

投稿日時 - 2019-07-20 13:44:12

ANo.19

(前回の回答より)

Sub CompareMain(ByRef rangeCompare As Range, ByRef Rev As Revolving, ByRef aryCompare As Variant, ByRef rangeResult As Range, ByRef numResult As Integer, ByRef aryResult As Variant, ByRef clrCompare As Long)
 Dim i As Long, j As Integer, k As Integer, cnt As Integer
 Dim numRow As Integer, numCol As Integer '比較元セル範囲の左上の行番号、列番号。
 Dim numRev As Integer '使用するリボルビング配列の番号。
 Dim blnPaint() As Boolean 'そのセル位置を着色するか。Trueなら着色する。

 '比較する値を、出力する並びでaryResultに格納。
 numRow = rangeCompare(1).Row
 numCol = rangeCompare(1).Column
 For i = 1 To rangeCompare.Rows.Count
  aryResult(i, 1) = aryCompare(numRow + i - 1, numCol) '比較元の値をコピー
  cnt = numResult '結果の比較先の出力列番号。
  numRev = (i - 1) Mod (UBound(Rev.OffRow) + 1)
  For j = 1 To Rev.ResRow
   For k = 1 To Rev.ResCol
    aryResult(i, cnt) = aryCompare(numRow + i - 1 + Rev.OffRow(numRev) + j - 1, numCol + Rev.OffCol(numRev) + k - 1)
    cnt = cnt + 1
   Next k
  Next j
 Next i

 '着色するセル位置を検索
 ReDim blnPaint(1 To rangeResult.Rows.Count, 1 To rangeResult.Columns.Count)
 For i = 1 To rangeResult.Rows.Count
  For j = numResult To rangeResult.Columns.Count
   If aryResult(i, 1) = aryResult(i, j) Then
    blnPaint(i, 1) = True
    blnPaint(i, j) = True
   End If
  Next j
 Next i

 '更新停止
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 Application.Calculation = False
 'セルに出力、着色。
 rangeResult = aryResult 'セルに出力
 For i = 1 To rangeResult.Rows.Count
  For j = 1 To rangeResult.Columns.Count
   If blnPaint(i, j) = True Then
    rangeResult(i, j).Interior.Color = clrCompare
   End If
  Next j
 Next i
 '更新再開
 Application.EnableEvents = True
 Application.ScreenUpdating = True
 Application.Calculation = True
End Sub
******************************



>~インデックス有効範囲でない。となります。
aryResultかaryCompareで範囲外の番号を指定した時に起こるエラーですね。
今回のコードなら、エラーが出る前にエラートラップに引っかかる筈です。

投稿日時 - 2019-07-18 11:39:27

お礼

こんばんはmathmiさん。この前のエラーはお陰様で上手く行きました。ありがとうございます。

書き終えてから実行して気付いたんですが、そのままコードを写すとリボルビングセルの形で、今回はリボルビング範囲の形をしたかったので最初の説明にあるリボルビング範囲の形を填めると「インデックス有効範囲エラー」がでました。

黄色に変わっ場所はSub CompareMainのaryResult(i, cnt) = aryCompare(numRow + i - 1 + Rev.OffRow(numRev) + j - 1, numCol + Rev.OffCol(numRev) + k - 1)
でした。
何処をどうすればよろしいですか。

投稿日時 - 2019-07-22 00:19:44

ANo.18

データ指定の方法が分かりづらかったのと、パッチ当てでスパゲッティコード化しつつあったので、全体を修正しました。
今までのものを丸ごと差し替えて下さい。文字数制限に引っかかったので、2回に分けています。

データの設定方法としては
・比較元となるセル範囲(rangeCompare)を設定します。
・その値と比較する相対位置(Rev)をリボルビング配列で設定します。
・出力する基準セル(rangeResult)を設定します。
・比較先を出力するセルが、比較元を出力するセルの何列隣か(numResult)を設定します。


例えば
1.C12をM3に、C12.offset(-5,0).resize(1,7)=C7:I7をM3.offset(0,3)=O3から始まるO3:U3にコピーし、比較する
2.C13をM4に、C13.offset(-7,0).resize(1,7)=C6:I6をM4.offset(0,3)=O4から始まるO4:U4にコピーし、比較する
2.C14をM5に、C14.offset(-9,0).resize(1,7)=C5:I5をM5.offset(0,3)=O5から始まるO5:U5にコピーし、比較する
これを繰り返す場合の設定は、以下のようになります。
Set rangeCompare = myWS.Range("C12:C10000")
Rev.OffRow = Array(-5, -7, -9)
Rev.OffCol = Array(0, 0, 0)
Rev.ResRow = 1
Rev.ResCol = 7
Set rangeResult = myWS.Range("M3")
numResult = 3

1.D63をM3に、D63.offset(-55,0).resize(51,1)=C8:I58をN4.offset(0,2)=O4から始まるO4:BM4にコピーし、比較する
2.D64をM4に、D64.offset(-57,0).resize(51,1)=C7:I57をN5.offset(0,2)=O5から始まるO5:BM5にコピーし、比較する
これを繰り返す場合の設定は、以下のようになります。
Set rangeCompare = myWS.Range("D63:D10000")
Rev.OffRow = Array(-55, -57)
Rev.OffCol = Array(0, 0)
Rev.ResRow = 51
Rev.ResCol = 1
Set rangeResult = myWS.Range("N4")
numResult = 2

※Offset:基準となるセルから何行/何列移動したセル。
※Resize:基準となるセルを左上とた、何行/何列のセル範囲。


******************************
Option Explicit

Type Revolving
 OffRow As Variant 'Offset Row。基準セルから比較先セルへの相対行数。
 OffCol As Variant 'Offset Column。基準セルから比較先セルへの相対列数。
 ResRow As Integer 'Resize Row。比較先セル範囲の行数。
 ResCol As Integer 'Resize Column。比較先セル範囲の列数。
 v As Variant
End Type


Sub SetData()
'作業対象範囲等を設定するプロシージャ
 Dim temp As Variant
 Dim myWS As Worksheet '作業を行うワークシート。
 Dim rangeCompare As Range '比較元セル範囲。
 Dim Rev As Revolving 'リボルビング相対位置。
 Dim numCompare As Integer '比較先セル範囲個数。
 Dim aryCompare As Variant '比較するセル範囲の値。
 Dim rangeResult As Range '出力先セル範囲
 Dim numResult As Integer '結果を出力する際、比較先を比較元の何列隣から出力するか。0なら同じ列。
 Dim aryResult As Variant '結果の値を格納する配列。
 Dim clrCompare As Long '値が同じだった場合に着色する色


 '作業を行うワークシートを設定
 Set myWS = ActiveSheet

 '比較元セル範囲を設定
 Set rangeCompare = myWS.Range("C12:C10000")

 'リボルビング相対位置を設定
 Rev.OffRow = Array(-5, -7, -9)
 Rev.OffCol = Array(0, 0, 0)
 Rev.ResRow = 1
 Rev.ResCol = 7
 numCompare = Rev.ResRow * Rev.ResCol

 'エラートラップ
 If rangeCompare.Columns.Count > 1 Then
  MsgBox ("比較元が2列以上に設定されています。")
  Exit Sub
 End If
 If UBound(Rev.OffRow) <> UBound(Rev.OffCol) Then
  MsgBox ("リボルビング配列の行数と列数が異なっています。")
  Exit Sub
 End If
 If rangeCompare(1).Row + WorksheetFunction.Min(Rev.OffRow) <= 0 Or _
  rangeCompare(1).Column + WorksheetFunction.Min(Rev.OffCol) <= 0 Then
  MsgBox ("シート範囲外と比較しようとしています。")
  Exit Sub
 End If
 If Rev.ResRow <= 0 Or Rev.ResCol <= 0 Then
  MsgBox ("比較先行数もしくは列数が0以下です。")
  Exit Sub
 End If

 '比較セル範囲の値を取得
 Set temp = rangeCompare(rangeCompare.Count)
 Set temp = temp.Offset(WorksheetFunction.Max(0, WorksheetFunction.Max(Rev.OffRow) + Rev.ResRow - 1), 0)
 Set temp = temp.Offset(0, WorksheetFunction.Max(0, WorksheetFunction.Max(Rev.OffCol) + Rev.ResCol - 1))
 aryCompare = myWS.Range("A1", temp).Value

 '出力先セル範囲を設定。
 Set rangeResult = myWS.Range("M3") '結果基準セルを設定
 numResult = 3
 Set rangeResult = rangeResult.Resize(rangeCompare.Rows.Count, numResult + numCompare - 1)
 ReDim aryResult(1 To rangeResult.Rows.Count, 1 To rangeResult.Columns.Count)

 '着色する色を設定
 clrCompare = RGB(255, 255, 153)

 Call CompareMain(rangeCompare, Rev, aryCompare, rangeResult, numResult, aryResult, clrCompare)
End Sub

(以下次の回答へ)

投稿日時 - 2019-07-18 11:38:06

お礼

こんばんはmathmiさん。
End If
 If rangeCompare(1).Row + WorksheetFunction.Min(Rev.OffRow) <= 0 Or _
  rangeCompare(1).Column + WorksheetFunction.Min(Rev.OffCol) <= 0 Then
  MsgBox ("シート範囲外と比較しようとしています。")
  Exit Sub
の所でコンパイルエラーとなり修正候補はThen またはGo to
となります。引っかかった所は「Or_」です。
ご指示を楽しくお待ちしております。

投稿日時 - 2019-07-19 19:03:13

ANo.17

>最後辺りのNext k の所がひっきります。
エラーの種類は何なんでしょうか? aryResultやaryCompareの範囲外を参照してしまったのでしょうか? for-nextの組が足りないのでしょうか? 無いとは思いますが、Ifに対するEnd Ifがないのでしょうか?
エラーメッセージすらないと、判断に困ります。

>Next j や Next i は消すべきでしょうか?
いえ、必要です。

投稿日時 - 2019-07-17 03:16:50

補足

こんにちはmathmiさん。いつもお世話になり感謝します。
aryResult(i + 1, j + numResult + k) = aryCompare(i + nRow + colRelative - CompareRows + k, j + LBound(rev))
がデバッグで黄色くなり、インデックス有効範囲でない。となります。

後、Next k の下にNext j 、Next iと順番に入れた方がよろしいですか。

投稿日時 - 2019-07-17 16:11:31

お礼

こんにちはmathmiさん。いつもお世話になり感謝します。
aryResult(i + 1, j + numResult + k) = aryCompare(i + nRow + colRelative - CompareRows + k, j + LBound(rev))
がデバッグで黄色くなり、インデックス有効範囲でない。となります。

後、Next k の下にNext j 、Next iと順番に入れた方がよろしいですか。

投稿日時 - 2019-07-17 16:28:46

ANo.16

すみません。挙動が分かりづらいので、もう少し具体的な例をお願いしたいです。

1.C63をW3にコピー、C63-5=C58からC58-50=C8を、Y3から51列分のBW3にコピー。W8とY3:BW3を比較して、同値なら着色。
2.C64をW4にコピー、C64-7=C57からC57-50=C7を、Y4からBW4にコピー、値を比較。
以下、基準セルから引く値を循環させながら繰り返し。
(引く行数である-5/-7/-50等は変更可能。-50は固定、-5/-7は循環して繰り返し)

つまり、今まではC12とC5からI5を比較していたものを、C63とC58からC8の比較に変更する、という事でいいんでしょうか?


No12の段階から以下を修正します。なお、コメント部分は変更しなくても挙動に影響ありません。

[SetData]モジュールの

Dimを設定している場所に[Dim CompareRows As Integer '比較する行数]を追加。

[Set cellCompare = Range("C12") '比較の基準セルであるC12。]を[Set cellCompare = Range("C63") '比較の基準セルであるC63。]に変更

******************************
'リボルビングする行数を、各列毎に設定。
ReDim rev(3 To 9) '対象とするC列からI列の列番号。
rev(3).v = Array(-5, -7, -9)
rev(4).v = Array(-5, -7, -9)
rev(5).v = Array(-5, -7, -9)
rev(6).v = Array(-5, -7, -9)
rev(7).v = Array(-5, -7, -9)
rev(8).v = Array(-5, -7, -9)
rev(9).v = Array(-5, -7, -9)
*******これを以下に変更*******
'リボルビングする行数を設定。
ReDim rev(3 To 3) '対象とするC列の列番号。
rev(3).v = Array(-5, -7, -9)
CompareRows = 50
******************************

[Set rangeResult = myWS.Range("M3").Resize(UBound(aryCompare, 1) - cellCompare.Row + 1, UBound(rev) - LBound(rev) + numResult)]を[Set rangeResult = myWS.Range("M3").Resize(UBound(aryCompare, 1) - cellCompare.Row + 1, UBound(rev) - LBound(rev) + numResult + CompareRows)]に変更。

最後[Call CompareMain(aryCompare, cellCompare, rev, numResult, rangeResult, aryResult, clrCompare)]を[Call CompareMain(aryCompare, cellCompare, rev, numResult, rangeResult, aryResult, clrCompare, CompareRows)]に変更。


[CompareMain]モジュールの

最初[Sub CompareMain(ByRef aryCompare As Variant, ByRef cellCompare As Range, ByRef rev() As Revolving, ByRef numResult As Integer, ByRef rangeResult As Range, ByRef aryResult As Variant, ByRef clrCompare As Long, ByRef CompareRows As Integer)に変更

[Dim i As Long, j As Integer, n As Integer]を[Dim i As Long, j As Integer, k As Integer, n As Integer]に変更。

******************************
For j = 0 To UBound(aryResult, 2) - numResult
colRelative = rev(j + LBound(rev)).v(i Mod (UBound(rev(j + LBound(rev)).v) + 1))
aryResult(i + 1, j + numResult) = aryCompare(i + nRow + colRelative, j + LBound(rev))
*******これを以下に変更*******
For j = 0 To UBound(rev) - LBound(rev)
colRelative = rev(j + LBound(rev)).v(i Mod (UBound(rev(j + LBound(rev)).v) + 1))
For k = 0 To CompareRows
aryResult(i + 1, j + numResult + k) = aryCompare(i + nRow + colRelative - CompareRows + k, j + LBound(rev))
Next k
******************************




変更点は、ほぼCompareRowsを追加しただけです。
これでどうでしょうか?

追記:コードを作り直してもいいでしょうか? cellCompareで基準セルを設定していますが、これを参照元セル範囲(C12:C10000等)にした方がすっきりしそうなので、もう一度練り直してみようかと思っています。
そちらで適宜変更する個所は、そう変わらないと思います。

投稿日時 - 2019-07-15 03:23:16

お礼

こんばんはmathmiさん。最後辺りのNext k の所がひっきります。Next j や Next i は消すべきでしょうか?

投稿日時 - 2019-07-16 20:30:53

ANo.15

>同じ形の別のsheetで、M3にD列を軸とした形にしたい場合は何処を変えるとよろしいですか。

「 Set cellCompare = Range("C12") '比較の基準セルであるC12。」のC12を、比較の基点となるセルに変更します。この場合はD12でしょうか。

******************************
 ReDim rev(3 To 9) '対象とするC列からI列の列番号。
 rev(3).v = Array(-5, -7, -9)
 rev(4).v = Array(-5, -7, -9)
 rev(5).v = Array(-5, -7, -9)
 rev(6).v = Array(-5, -7, -9)
 rev(7).v = Array(-5, -7, -9)
 rev(8).v = Array(-5, -7, -9)
 rev(9).v = Array(-5, -7, -9)
******************************
以上のリボルビング配列を適宜変更します。
例えばD列からF列と比較したい場合、[ReDim rev(4 To 6)]とします。
下の配列も、rev(4).v、rev(5).v、rev(6).vだけ設定して、rev(3).v、rev(7).v、rev(8).v、rev(9).vは削除します。
この配列を変更しないと、D12と、C7~I7を比較する事になってしまいます。

以上の二か所を変更すれば大丈夫の筈です。

投稿日時 - 2019-07-10 21:28:39

補足

なんでそんなに私が知りたい所を忖度出来たんですかw(゜o゜)w
凄い!ありがとうございます。お礼でまた質問させて頂きます。

投稿日時 - 2019-07-10 23:22:39

お礼

こんばんはmathmiさん。この流れでの質問が出来たのでよろしければご協力お願いいたします。

ざっくり言いますと、今までのがリボルビングセルコピペだったのを改造して、リボルビング範囲横化コピペにしたいです。
C63からを対象軸にして、W3にC63の値を入れ、対象範囲はC列(C63)から-50行をリボルビング性能を利用して横化してY3から下に値をコピペするという形にして欲しいです。
色のことに関してはこの前と同じで、Wの値と水平上にある同じ値のセル背景を全部同じ色にします。
rev(3).v = Array(-5, -7, -9)の形を利用したら初めの範囲はC63-5なんで範囲はC8:C58になりY3に横化して値をコピペという形です。
できるものなんですかね。

投稿日時 - 2019-07-14 20:39:44

ANo.14

>この質問の続きをさせて頂けませんか?
はい。大丈夫です。
何でしょうか?

投稿日時 - 2019-07-10 15:16:15

お礼

こんばんは、mathmiさん。
同じ形の別のsheetで、M3にD列を軸とした形にしたい場合は何処を変えるとよろしいですか。

投稿日時 - 2019-07-10 18:48:59

ANo.13

>これはNo.9の解答に対して行えばよろしいですか?
はい。その通りです。

変更する箇所の指定が、No.9のコードにしかなかった為に、明示せずとも分かるだろうな、と判断してしまいました。
以後は、一部変更するだけでも、コード全文載せた方がいいでしょうか?

投稿日時 - 2019-07-10 09:11:17

補足

mathmiさん!!!すみません。!!!
いつの間にか(A1:I10000)のところが (A1:D10000)に変わってました。(T_T)

すみません。治してやってみたら素晴らしくスッキリとたんじかんで成功しました。ありがとうございました。

投稿日時 - 2019-07-10 14:18:03

お礼

こんにちはmathmiさん。やってみましたが、それでも
aryResult(i + 1, j + numResult) = aryCompare(i + nRow + colRelative, j + LBound(rev))
が先述したのと変わらないエラーになります。

revの値も変えずそのままで、何度も目で文字間違い等ないか
確認したんですけど、変わらずです。

投稿日時 - 2019-07-10 13:35:02

ANo.12

リボルビング配列に正の値を入れた時にエラーが発生するバグをデバッグしてみました。先のコードの、以下の2点を変更してみて下さい。


>Dim i As Integer, temp As Variant
この行を、以下の2行に変更して下さい。
******************************
Dim i As Integer, j As Integer, temp As Variant
Dim nMax As Integer, nMin As Integer 'リボルビングの最大値、最小値を格納。
******************************


>'着色する色を設定
>clrCompare = RGB(255, 255, 153)
この行の直前に、以下を追加して下さい。
******************************
 'リボルビング配列の最大値、最小値を取得
 For i = LBound(rev) To UBound(rev)
  For j = 0 To UBound(rev(i).v)
   If nMax < rev(i).v(j) Then
    nMax = rev(i).v(j)
   End If
   If rev(i).v(j) < nMin Then
    nMin = rev(i).v(j)
   End If
  Next j
 Next i

 '比較する値の範囲を確認。
 If cellCompare.Row + nMin <= 0 Then
  MsgBox ("シート範囲外の値を比較しようとしています。マクロを中止します。")
  Stop
 End If
 If 0 < nMax Then
  aryCompare = myWS.Range(Range("A1"), myWS.Cells(UBound(aryCompare, 1) + nMax, UBound(aryCompare, 2))).Value
 End If
******************************

投稿日時 - 2019-07-09 16:23:13

お礼

これはNo.9の解答に対して行えばよろしいですか?
今、頭がこんがらがってます w

投稿日時 - 2019-07-09 17:49:26

ANo.11

申し訳ありません。間違って古い回答を送ってしまいました。

>エラー9になりインデックスが有効範囲にありません
aryResultの範囲外に値を設定しようとしたか、aryCompareの範囲外から値を取得しようとしている模様です。

こちらでRev配列に正の値を入れてみると、同じエラーがでました。
もし、そちらでも同様にしていたのならば、エラーの原因はそこだと思います。

修正しますので、デバッグは少々お待ちください。

投稿日時 - 2019-07-09 15:47:03

お礼

謝られるなんてとんでもないです。ご助力頂けていつも感謝しかないです。
あんなに丁寧に説明されてたら参考書とか作ってるのかなって思えるぐらい有難いです。
待たせて頂きます。(^^)

投稿日時 - 2019-07-09 16:19:30

ANo.10

こちらで走らせた限りでは、エラーは出ないのですが。

>エラー9になりインデックスが有効範囲にありません
aryResultの範囲外に値を設定しようとしたか、aryCompareの範囲外から値を取得しようとしている模様です。

・Revの配列はどうなっていますか? プラスとマイナスは大丈夫ですか?
・i+nRow+colRelativeの値が0以下になっていませんか?
・変数の内容を変更した箇所あれば教えて下さい(aryCompareの範囲等)。

投稿日時 - 2019-07-09 15:45:38

お礼

変数は変えてないんです。

投稿日時 - 2019-07-10 13:29:25

ANo.9

遅くなって申し訳ありません。
連絡頂きました通り、マクロを組みなおしました。

***アルゴリズム***
・C12の値をM3にコピーする
・C12から一定行遡った(この場合は5)セルを、O3にコピーする。
・12行目から一定行遡ったD列のセルを、P3にコピーする。
・同様にE、F、G、H、I列をQ3、R3、Q3、R3、U3にコピーする。
・遡る行数は、各列毎に別々に設定する。
・M3の値とQ3~U3の値を比較し、同じ値があった場合は、M3とその同じ値のセルに着色する。
・同様に、C13の値をM4にコピーするが、その際に遡る行数は、C12の時とは異なる。
・遡る行数は、一定周期で繰り返す。
・作業対象セルは約10000行
******************

[Revolving]でリボルビング用構造体を作成し、[SetData]プロシージャで各種設定を読み込み、[CompareMain]プロシージャで処理をしています。
複数の設定で処理をしたい場合、それぞれの設定毎に[SetData]プロシージャを作り(名前はそれぞれ分ける)、そこから[CompareMain]を呼び出して比較作業する事ができます。

変更を想定している変数は以下の通りです。
myWS :処理を行うシート
aryCompare :比較する値。rangeは、実際に比較する範囲より小さくては駄目だが、大きいなら問題ない。
cellCompare:比較する基準セル。今回はC12
Rev(n) :リボルビング用配列。n列目の比較先の値が、基準セルより何行先か。配列は現状(-5,-7,-9)だが、例えば(-1,-5,-8,-10)や(-2,-3)等でも構わない。
numResult :出力する際、比較元と、最初の比較先が何列離れているか。今回はM->Oなので3。
clrCompare :値が同じだった場合に着色する色。


privateではないので、それぞれを別のモジュールに分けてもかまいません。
今回のマクロも、今回だけで過不足なく完結していますので、以前に返答したマクロは必要ありません。また、全てのプロシージャをエクセルにコピーして下さい。


Option Explicit

Type Revolving
 v As Variant
End Type



Sub SetData()
'作業対象範囲等を設定するプロシージャ
 Dim i As Integer, temp As Variant
 Dim myWS As Worksheet '作業を行うワークシート。
 Dim aryCompare As Variant '比較するセル範囲の値。
 Dim cellCompare As Range '比較を開始する基準となるセル。
 Dim rev() As Revolving '各行の比較先が、基準セルの何行上かを格納する配列。
 Dim numResult As Integer '結果を出力する際、比較先を比較元の何列隣から出力するか。0なら同じ列。
 Dim rangeResult As Range '結果を出力する範囲。
 Dim aryResult As Variant '結果の値を格納する配列。
 Dim clrCompare As Long '値が同じだった場合に着色する色

 '比較元であるセル範囲を設定。
 Set myWS = ActiveSheet
 aryCompare = myWS.Range("A1:I10000").Value '配列番号=セル番号とするため、A1から開始する。
 Set cellCompare = Range("C12") '比較の基準セルであるC12。

 'リボルビングする行数を、各列毎に設定。
 ReDim rev(3 To 9) '対象とするC列からI列の列番号。
 rev(3).v = Array(-5, -7, -9)
 rev(4).v = Array(-5, -7, -9)
 rev(5).v = Array(-5, -7, -9)
 rev(6).v = Array(-5, -7, -9)
 rev(7).v = Array(-5, -7, -9)
 rev(8).v = Array(-5, -7, -9)
 rev(9).v = Array(-5, -7, -9)

 '出力先セル範囲、及び出力する値を設定
 numResult = 3
 Set rangeResult = myWS.Range("M3").Resize(UBound(aryCompare, 1) - cellCompare.Row + 1, UBound(rev) - LBound(rev) + numResult)
 ReDim aryResult(1 To rangeResult.Rows.Count, 1 To rangeResult.Columns.Count)

 '着色する色を設定
 clrCompare = RGB(255, 255, 153)

 Call CompareMain(aryCompare, cellCompare, rev, numResult, rangeResult, aryResult, clrCompare)
End Sub



Sub CompareMain(ByRef aryCompare As Variant, ByRef cellCompare As Range, ByRef rev() As Revolving, ByRef numResult As Integer, ByRef rangeResult As Range, ByRef aryResult As Variant, ByRef clrCompare As Long)
 Dim i As Long, j As Integer, n As Integer
 Dim nRow As Integer, nCol As Integer '基準セルの行番号、列番号。
 Dim colRelative As Integer '相対行数。
 Dim blnPaint() As Boolean 'そのセル位置を着色するか。Trueなら着色する。

 '比較する値を、出力する並びでaryResultに格納。
 nRow = cellCompare.Row
 nCol = cellCompare.Column
 For i = 0 To UBound(aryResult, 1) - 1
  aryResult(i + 1, 1) = aryCompare(i + nRow, nCol) 'M列用
  For j = 0 To UBound(aryResult, 2) - numResult
   colRelative = rev(j + LBound(rev)).v(i Mod (UBound(rev(j + LBound(rev)).v) + 1))
   aryResult(i + 1, j + numResult) = aryCompare(i + nRow + colRelative, j + LBound(rev))
  Next j
 Next i

 '着色するセル位置を検索
 ReDim blnPaint(1 To rangeResult.Rows.Count, 1 To rangeResult.Columns.Count)
 For i = 1 To UBound(aryResult, 1)
  For j = numResult To UBound(aryResult, 2)
   If aryResult(i, 1) = aryResult(i, j) Then
    blnPaint(i, 1) = True
    blnPaint(i, j) = True
   End If
  Next j
 Next i

 '更新停止
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 Application.Calculation = False
 'セルに出力、着色。
 rangeResult = aryResult 'セルに出力
 For i = 1 To UBound(aryResult, 1)
  For j = 1 To UBound(aryResult, 2)
   If blnPaint(i, j) = True Then
    rangeResult(i, j).Interior.Color = clrCompare
   End If
  Next j
 Next i
 '更新再開
 Application.EnableEvents = True
 Application.ScreenUpdating = True
 Application.Calculation = True
End Sub

投稿日時 - 2019-07-08 15:21:51

お礼

こんにちはmathmiさん。ご助力頂けて感謝しかないです。只今エラーになっておりまして、
「エラー9になりインデックスが有効範囲にありません」となり

aryResult(i + 1, j + numResult) = aryCompare(i + nRow + colRelative, j + LBound(rev))

が黄色になります。
どうしたらよろしいですか。

投稿日時 - 2019-07-09 15:22:14

ANo.8

>これは全部書いたら良いのですか?
はい。No.7に書いたコードは、全部で一式のコードです。以前にお答えしたモジュールは必要ありませんが、No.7のコードは全て書いてください。
subの前にprivateを付けてはいないので、別のモジュールに分けても大丈夫です。
検索する範囲等を変更したい場合、[GetData]プロシージャで指定しているセル等を変更すれば、それなりに柔軟に対応できると思います。

[testMain]プロシージャで起動します。ボタンに紐付けるか、別のプロシージャから呼んでください。
[GetData]プロシージャで、検索するセル範囲や出力するセル範囲等を指定します。
[CompareValue]プロシージャで、出力する値の並びをaryResult配列に格納しています。
[OutputResult]プロシージャで、実際にシートに出力し、比較、着色処理を行っています。


挙動が想定と違う、ここはこうしたい等ありましたら、連絡お願いします。

投稿日時 - 2019-07-05 01:37:30

お礼

mathmiさん、こんばんは!やってみました。一瞬でサーっっっと出来て素晴らしかったです。その部分は予想外で凄かったですし本当にビックリしました\(^_^)/。
ですが訂正したく思いまして、
私がしっかりと伝えきれてなかった事に気付きました。あなたは間違ってなんかおられません!私です_(^^;)ゞ。D列もしてくれてたみたいで、そこがちょっと私の付けたし付けたしの説明で混乱させたみたいです。欲が先行しちゃいました。
すみません。
ではここから説明させていただきます

C12以降の記号がM3以降に1つずつ
コピペされます。
でO3以降へのリボルビングコピペは私の質問した通りで成功させて頂きました。ありがとうございます。

このsheetではC列を中心でしたく思いますのでC12以降のセル値1つ1つを軸ととらえて頂いてリボルビングコピペをして頂きました。
軸としてコピペされたM3の値はC12の値と同じで、C12から5行戻ったC7の値がO3にリボルビングコピペされて同じ値なら双方が黄色になる、それが成功です。
ここからが欲張りになります。O3以降がC列からリのボルビングで取り出した値ならば
P3はC12を軸としてD列からのリボルビングコピペQ3はC12を軸としてE列からのリボルビングコピペR3はC12を軸としてF列からのリボルビングコピペS3はC12を軸としてG列からのリボルビングコピペT3はC12を軸としてH列からのリボルビングコピペU3はC12を軸としてI列からのリボルビングコピペ
をしたいです。

戻りリボルビング数は全部バラバラでも大丈夫なようにするのと、自分でも設定できるようにしたいです。後、M列の値とP以降の列の値が同じ値ならば、M列も含めて同じ値同士が黄色になるようにしたいです。(複数同じなら複数黄色)

(D列を軸にするのはまた別個で別のbookなんです。(^_^ゞ)伝え損じててすみませんでした。

何度とすみませんが私の力では到底到達出来そうにないので宜しくお願い致します。

投稿日時 - 2019-07-06 21:02:40

ANo.7

>使い難いなぁ
確かに、起点セルの設定の仕方が少し複雑でしたね。

>質問通りの内容
以下のような処理でよろしいでしょうか?(以前のコードは、出力する列をMとNに勘違いしていました)
・あるセル(例:C12)と、そこから一定行(例:5)上に遡ったセル(例:C7)の値を、別のセル(例:M3)とその一定列(例:3)隣のセル(例:O3)にコピーする。
・二つの値を比較し、同じならば、別のセル(例:M3)を着色(例:黄色)する。
・あるセルの下のセル(例:C13)と、そこから次の一定行(例:7)上に遡ったセル(例:C6)を、別のセルの下のセル(例:M4)とその一定列(例:3)隣隣のセル(例:O4)に、同様にコピー、比較、着色する。
・あるセルの二つ下のセル(例:C14)と、そこから次の一定行(例:9)上に遡ったセル(例:C5)を、別のセルの二つ下のセル(例:M5)とその一定列(例:3)隣のセル(例:O5)に、同様にコピー、比較、着色する。
・三つ下のセル(例:C15)も同様に処理するが、上に遡る行数は最初に戻る(例:5)。
・以上を、一定範囲に対して繰り返す(例:C12からD10000)。
・別の列に対しても、同様に処理する(例:D12とD7をP3とR3にコピー、比較する)。


比較する範囲や出力する範囲等を、一つのプロシージャを書き換える事で変更できるようにしました。
また、出力する数が数万になるので、一つ一つ出力するのではなく、variant型から一気にセルに出力するようにしました。
速度上昇のため、更新停止するコードを追加しました。

Option Explicit

Sub testMain()
 Dim aryCompare As Variant '比較するセル範囲の値。
 Dim numCompare As Integer '比較する配列内で、比較を開始する行番号。
 Dim numResult As Integer '比較する値を何列隣に出力するか。
 Dim rangeResult As Range '結果を出力する範囲。
 Dim aryResult As Variant '結果を格納する配列。
 Dim Revolving() As Integer 'rangeCompareを、何行離れたセルと比較するか。
 Dim clrCompare As Long '値が同じだった場合に着色する色

 Call GetData(aryCompare, numCompare, numResult, rangeResult, aryResult, Revolving, clrCompare)

 Call CompareValue(aryCompare, numCompare, numResult, aryResult, Revolving)

 Call OutputResult(numResult, rangeResult, aryResult, clrCompare)
End Sub



Sub GetData(ByRef aryCompare As Variant, ByRef numCompare As Integer, ByRef numResult As Integer, ByRef rangeResult As Variant, ByRef aryResult As Variant, ByRef Revolving() As Integer, ByRef clrCompare As Long)
'変更する可能性のある値を設定しているプロシージャ。
'比較元のセル範囲、比較する2つの数の相対列数、比較先のセル範囲、比較する時の循環する相対行数、着色する色を設定している。
 Dim i As Integer, temp As Variant
 Dim myWS As Worksheet '作業を行うワークシート。
 Set myWS = ActiveSheet
 aryCompare = myWS.Range("C5:D10000").Value
 numCompare = Range("C12").Row - Range("C5").Row

 numResult = 3
 Set rangeResult = myWS.Range("M3").Resize(UBound(aryCompare, 1) - numCompare, UBound(aryCompare, 2) * numResult)
 ReDim aryResult(1 To rangeResult.Rows.Count, 1 To rangeResult.Columns.Count)

 temp = Array(-5, -7, -9) '循環する比較セル相対位置を仮受。
 ReDim Revolving(UBound(temp))
 For i = 0 To UBound(temp)
  Revolving(i) = temp(i)
 Next i

 clrCompare = RGB(255, 255, 153)
End Sub



Sub CompareValue(ByRef aryCompare As Variant, ByRef numCompare As Integer, ByRef numResult As Integer, ByRef aryResult As Variant, ByRef Revolving() As Integer)
'比較する値をaryResultに格納する。
 Dim i As Long, j As Integer, n As Integer
 n = UBound(Revolving) - LBound(Revolving) + 1
 For j = 1 To UBound(aryCompare, 2)
  For i = 1 To UBound(aryCompare, 1) - numCompare
   aryResult(i, (j - 1) * numResult + 1) = aryCompare(i + numCompare, j)
   aryResult(i, (j - 1) * numResult + numResult) = aryCompare(i + numCompare + Revolving((i - 1) Mod n), j)
  Next i
 Next j
End Sub



Sub OutputResult(ByRef numResult As Integer, ByRef rangeResult As Range, ByRef aryResult As Variant, ByRef clrCompare As Long)
'比較する値を出力し、値を比較して、必要ならばセルを着色する。
 Dim i As Integer, j As Integer

 '更新停止
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 Application.Calculation = False

 rangeResult = aryResult 'セルに出力
 For j = 1 To UBound(aryResult, 2) Step numResult '値を比較
  For i = 1 To UBound(aryResult, 1)
   If aryResult(i, j) = aryResult(i, j + numResult - 1) Then
    rangeResult(i, j).Interior.Color = clrCompare
   End If
  Next i
 Next j

 '更新再開
 Application.EnableEvents = True
 Application.ScreenUpdating = True
 Application.Calculation = True
End Sub

投稿日時 - 2019-07-02 17:30:14

お礼

こんばんはmathmiさん。すみません。これは全部書いたら良いのですか?

投稿日時 - 2019-07-04 22:54:08

ANo.6

>Subからはじまるソースはこの件ではするべきでは無いのですか。
いえ、そんな事はありません。
単に、そのプロシージャが、そのモジュール内でだけ使用されるか、全てのモジュールで使用されるかを明確化するだけのものですから(適用範囲、スコープと言います)。
最初のPrivateを削除しても全然問題ありません。その方が簡単かもしれません。

>Call CheckCellがコンパイルエラーして、Subまたは Functionが定義されてない
[testMain]プロシージャと[CheckCell]プロシージャを別モジュール(例えば標準モジュールのModule1とModule2のように)に分けていませんか?
Privateプロシージャは別のモジュールからは呼べないので、その場合「呼んでいるCheckCellプロシージャは、利用可能な範囲にはありません」として、そのエラーが出ます。


後、コピーで使用できるものが欲しいのでしたら、もっと機能と構造を明確にして貰わないと、こちらとしてもどうにもできません。
正直、Private/Publicの変更とか、CheckCellの呼び出し方(Forループで呼び出すとか、対象セルを配列に格納するとか)を、そちらで調整して貰う前提でコードを書いていたので。

投稿日時 - 2019-07-02 09:30:20

お礼

こんにちはmathmiさん。理解も少しできたし作動もしました。(まだまだ初心者です。f(^_^;))
最初に作って頂いたソースが上手く行かないので
質問通りの内容でソースだけ書いて頂けたらと、お願いいたします。
昨日に作って頂いたのが作動はしたんですが、上手く行かなかったのと自分でも使い難いなぁと思いました。

投稿日時 - 2019-07-02 15:07:22

ANo.5

>標準モジュールに書くとどのようなソースになりますか?
既存のルーチンに繋げる訳ではないのでしょうか?

>まだまだ対象列を増やす予定です。
挙動が少し違っているかもしれませんが、これでどうでしょう?
一応C12~E22をM,O,Q3~35に出力してみました。
forループの辺りを調整すれば、対象列を変更できます。

[Module1]
Option Explicit

Private Sub testMain()
 Dim i As Integer, j As Integer
 Dim clr_Yellow As Long
 Dim myWS As Worksheet

 clr_Yellow = RGB(255, 255, 153)
 Set myWS = ActiveSheet
 For i = 0 To 10
  For j = 0 To 2
   Call CheckCell(myWS.Cells(12 + i * 3, 3 + j), myWS.Cells(3 + i * 3, 13 + j * 2), clr_Yellow)
  Next j
 Next i
End Sub


Private Sub CheckCell(ByRef cellFrom As Range, ByRef cellTo As Range, ByRef clr_Yellow As Long)
'cellFrom(0,0)をCellTo(0,0)にコピー、cellFrom(-5,0)をCellTo(0,1)にコピー
'コピーした値を比較し、同じならcellTo(0,0)を着色
'cellFrom(1,0)をCellTo(1,0)にコピー、cellFrom(1-7,0)をCellTo(1,1)にコピー、同様にチェック
'cellFrom(2,0)をCellTo(2,0)にコピー、cellFrom(2-9,0)をCellTo(2,1)にコピー、同様にチェック
 Dim i As Integer

 For i = 0 To 2
  cellTo.Offset(i, 0).Value = cellFrom.Offset(i, 0).Value
  cellTo.Offset(i, 1).Value = cellFrom.Offset(i - 5 - i * 2, 0).Value
  If cellTo.Offset(i, 0).Value = cellTo.Offset(i, 1).Value Then
   cellTo.Offset(i, 0).Interior.Color = clr_Yellow
  End If
 Next i
End Sub

投稿日時 - 2019-07-01 10:00:44

補足

すんません。privateも苦手です。
Subからはじまるソースはこの件ではするべきでは無いのですか。

投稿日時 - 2019-07-01 18:27:53

お礼

こんばんは、mathmiさん。
ご返答ありがとうございます。

Call CheckCellがコンパイルエラーして、Subまたは Functionが定義されてない、となります。
どうしたらよろしいでしょうか?

投稿日時 - 2019-07-01 18:22:40

ANo.4

確認してなかったのでスペルミスがありました。
最後のcell_pasetはcell_Pasteの誤りです。

>マクロを開いてする
Visual Basic Editerから実行する、という意味でしょうか?
test2は、引数(n_Check)を必要とするので、他のプロシージャから引数を与えて呼び出す必要があります。

>作動のさせかたがわかりません。
下記のようなコードで、連続して処理する事を想定しています。
test2プロシージャはPrivateなので、同じモジュールから呼び出すか、Publicに変更する必要があります。
Public Sub test3()
 Dim i As Integer
 For i = 1 To 10
  Call test2(i)
 Next i
End Sub

もし手動で、ボタンに紐づけたマクロで起動する場合、#1のSearchRowプロシージャと#3のtest2プロシージャと、下のプロシージャを同じモジュールに張り付け、ボタンにtest4を紐づければ作動します。
#1のプロシージャをそのまま使った方がすっきりするかも知れませんが。
Public Sub test4()
 Call test2(SearchRow - 2)
End Sub

投稿日時 - 2019-06-28 09:31:25

お礼

mathmiさん、ご回答ありがとうございます。
標準モジュールに書くとどのようなソースになりますか?
また、C12から下に1つずつ進むにつれて5、7、9とリボルビング行戻りコピペをO3から下に向かいながらするソースですが、
付け加えて欲しいのがありまして、

それがC12から下に1つずつ下に向かう度に右に一列ずれたD列の5、7、9とリボルビング行戻りコピペをもP3から下に向かってしたいです。
リボルビング行戻りの数字を自分でコードに設定すれば出来るようにしたいですし、D列をも対象にして一緒に出来るようP列増しも出来るようにしたいです。
まだまだ対象列を増やす予定です。
お願いいたします。

今までほとんど標準モジュールでやってきたのでpublicに抗体ができてる気がします。f(^_^;

投稿日時 - 2019-07-01 04:22:52

ANo.3

>マクロを指定回数繰り返しするソースはあります。
手動でマクロボタンを押すのではなく、プログラムでサブルーチンを叩くのなら、わざわざセルにどこまで入力したかを調べなくても、何行目をチェックするかを引数で与えてやればいいので、コードはもっとすっきりできますね。

Private Sub test2(ByVal n_Check As Long)
 Dim cell_Copy As Range 'コピー元セル
 Dim cell_Paste As Range 'コピー先セル
 Dim ary_Minus(0 To 2) As Integer '減算する行数を格納する配列
 Dim clr_Yellow As Long '着色する色

 Set cell_Copy = Cells(n_Check + 12, 3)
 Set cell_Paste = Cells(n_Check + 2, 13)
 ary_Minus(0) = 9: ary_Minus(1) = 5: ary_Minus(2) = 7
 clr_Yellow = RGB(255, 255, 153)

 cell_Paste.Value = cell_Copy.Value
 cell_Paste.Offset(0, 1).Value = cell_Copy.Offset(-ary_Minus(n_Check Mod 3), 0).Value
 
 If cell_Paste.Value = cell_paset.Offset(0, 1).Value Then cell_Paste.Interior.Color = clr_Yellow
End Sub

投稿日時 - 2019-06-27 11:47:28

お礼

Mathmiさん、返事ありがとうございます。書いてみましたが、作動のさせかたがわかりません。
いつもはマクロを開いてするんですが、見あたりません。

投稿日時 - 2019-06-28 05:29:29

ANo.2

至急、補足されたい。
(5)の「1つ下のM4に」のM4はM5が正しいのでは?
ここで、規則性がくずれている、が?
C12→C13→C14→・・
C7→C6→C5→ ・・・
M3→M4→M4・・ ここの3つ目のM4はM5?
O3→O4→O5・・
ーー
こんなのは、中学の数学の「級数」の問題に過ぎないのでは?
>マクロボタンを押します。
「マクロボタン」とは。コマンドボタンにマクロを登録したいのか。
なぜ毎回押させるのか?かえって初心者にはむつかしくなると思うが。
ーー
C7→C6→C5・・で
行が減少して1以下になったら、その後どうするの?

投稿日時 - 2019-06-27 09:44:56

お礼

imogasiさん、ご返事ありがとうございます。間違えてました。M5です。

C12-5行目、C13-7行目、C14-9行目、C15-5行目、C16-7行目、C17-9行目、C18-5行目、………と引く行目はループしながら
その記号値をO3から下に向かって入れていきたいんです。且つ、M列とO列の平行上に、同じ記号ならMの方のセル背景色が黄色になるようにしたいです。
マクロを指定回数繰り返しするソースはあります。

投稿日時 - 2019-06-27 10:20:34

ANo.1

比較する組は(C12,C7)(C13,C6)(C14,C5)(C15,C10)(C16,C9)(C17,C8)(C18,C13)(C19,C12)(C20,C11)……でしょうか(例えばC12は、C7とC19相手に二回比較する)。

簡単に組んでみました。マジックナンバー多めなんで、適宜変数に格納するなどして下さい。


Public Sub test()
 Dim CellCheck As Range 'コピー元セル
 Dim TargetRow As Long 'コピー先行数
 Dim n_Reverse As Integer '何行戻るか
 TargetRow = SearchRow
 
 Set myCell = Cells(TargetRow + 9, 3)
 n_Reverse = ((TargetRow + 9) Mod 3) * 2 + 5

 'セルの値をコピー
 Cells(TargetRow, 13).Value = myCell.Value
 Cells(TargetRow, 14).Value = myCell.Offset(-n_Reverse, 0).Value

 '比較
 If Cells(TargetRow, 13).Value = Cells(TargetRow, 14).Value Then
  Cells(TargetRow, 13).Interior.Color = RGB(255, 255, 153)
 End If
End Sub

Private Function SearchRow() As Long
'次に入力するのがM列の何行目か
 Dim myCell As Range
 Set myCell = Range("M3")
 If IsEmpty(myCell) Then
  SearchRow = 3
 ElseIf IsEmpty(myCell.Offset(1, 0)) Then
  SearchRow = 4
 Else
  SearchRow = myCell.End(xlDown).Row + 1
 End If
End Function

投稿日時 - 2019-06-27 09:42:49

お礼

ありがとうございますmathmiさん。今までの内容を理解して頂けやすいのはmathmiさんだけなんで、この質問の続きをさせて頂けませんか?

投稿日時 - 2019-07-10 14:41:26

あなたにオススメの質問