Excel2007で複雑なセルコピペ。

質問

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

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

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

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

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

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

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

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

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

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

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

回答No.20

Mathmi · ベストアンサー

＞コンパイルエラーとなり修正候補は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

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

お礼

こんばんは、mathmiさん。お久しぶりです。なかなかできる時間がつくれませんでした。また同じ形で質問スレ立てますんで続きを相手して下さい。

回答No.21

Mathmi

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

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

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

お礼

ありがとうございました。

回答No.19

Mathmi

（前回の回答より）

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で範囲外の番号を指定した時に起こるエラーですね。
今回のコードなら、エラーが出る前にエラートラップに引っかかる筈です。

お礼

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

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

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

回答No.18

Mathmi

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

（以下次の回答へ）

お礼

こんばんは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_」です。
ご指示を楽しくお待ちしております。

回答No.17

Mathmi

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

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

お礼

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

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

補足

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

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

回答No.16

Mathmi

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

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等)にした方がすっきりしそうなので、もう一度練り直してみようかと思っています。
そちらで適宜変更する個所は、そう変わらないと思います。

お礼

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

回答No.15

Mathmi

＞同じ形の別の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を比較する事になってしまいます。

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

お礼

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

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

補足

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

回答No.14

Mathmi

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

お礼

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

回答No.13

Mathmi

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

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

お礼

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

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

補足

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

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

回答No.12

Mathmi

リボルビング配列に正の値を入れた時にエラーが発生するバグをデバッグしてみました。先のコードの、以下の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
******************************

お礼

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

回答No.11

Mathmi

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

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

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

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

お礼

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