[VBA]指定の範囲内で繰り返す

質問

こちらの識者の方々にはいつもお世話になっています。
VBAの質問です。

環境は下記になります。
OS=windows7 pro 64bit
Office=Excel2010(14.0.7128.5000)

・やりたいこと
題名に大いに不足があり申し訳ないです（文字制限の中で適切に表現できませんでした）。
添付ファイルのようなリストがあり、マクロを実行するたびに"CRT","CRN","MRT","MRN"を一つ↓にずらしてループさせたいのですが、
"CRT","CRN"についてはB列の値0の範囲内で、"MRT","MRN"についてはB列の値1の範囲内でそれを行いたいのです。
つまり、"CRN"が16行目にあるときに実行したら、"CRN"を2行目に持ってくる（"CRT"も同様）、
"MRN"が31行目にあるときに実行したら"MRN"を17行目に持ってくる、という感じです。

Cat0,1ともに15個ですので下段の通り現在はMOD関数でカウンター変数の余りを求めて処理していますが、
あまりいい処理とは思えません。
（Cat0,1共に同一数でなければならないという制約が付くので）

Option Explicit
Option Base 1

Sub hoge2()
　Dim Wb As Workbook, Ws As Worksheet
　Dim i As Long, iNA As Long, EndRow As Long
　Dim mtxNI As Variant, mtxNA As Variant

　Set Wb = ThisWorkbook
　Set Ws = Wb.Sheets(3)
　EndRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row
　mtxNI = Ws.Range("A1:J" & EndRow).Value

　mtxNA = Array("CRT", "CRN", "MRT", "MRN")
　For iNA = 1 To UBound(mtxNA)
　　For i = 2 To EndRow
　　　If mtxNI(i, 10) = mtxNA(iNA) Then
　　　　mtxNI(i, 10) = ""
　　　　If i Mod 15 = 1 Then
　　　　　mtxNI(i - 14, 10) = mtxNA(iNA)
　　　　Else
　　　　　mtxNI(i + 1, 10) = mtxNA(iNA)
　　　　　Exit For
　　　　End If
　　　End If
　　Next i
　Next iNA
　Ws.Range("A1:AO" & EndRow).Value = mtxNI

End Sub

この場合どのようなコードが適していますでしょうか。
まだまったく理解できていませんが、クラスモジュールのほうが適しているのでしょうか？

質問に不備不足等ございましたらご指摘ください。
ご面倒お掛けしますがよろしくお願いします。

回答No.5

real beatin（@realbeatin） · ベストアンサー

こんにちは。お邪魔します。

> もっと平易というか、保守性が高く、無駄のない、可読性に優れたコードが無いものかと ...
人様への返信を引用するのは恐縮なのですが、
そうありたいとは恒に思いつつも中々その通りには出来ない、
という、、、高い理想、である訳で、気後れしそうですが、
私なりに努めて答えを書いてみます。
ただ、「保守性」ということになると「メンテのし易さ」まで慮って、
「無駄のなさ」「可読性」という点でギャップを大きく感じる方も
居られるでしょうから、多分に管理者の個性に頼る面もあり、
相対的になるのはある程度避けられないだろうとは思います。
私なりに書くと、少し保守寄り（？そんなキャラではありませんが自分の職場の基準寄り）
になってしまうのかな？と。
なので、解（ほぐ）したいところは適当に手直しを入れて貰えればな、と思いつつ書きました。

> "CRT","CRN"についてはB列の値0の範囲内で、"MRT","MRN"についてはB列の値1の範囲内で
このての対応関係を表す、定義（テーブル/辞書）、については、
Excelでは本来、シート上に表現しておく方が保守的ですし設計が簡易になります。
（余談。一昔前ならCustomDocumentProperties、今ならCustomXMLPartsを使う方法もあるようですが、
　それこそ、マクロを読むだけでは気が付かないものになってしまいます）
　　"CRT"　0
　　"CRN"　0
　　"MRT"　1
　　"MRN"　1
という対応関係を解り易くする、というのは、「可読性」に直結するのではないでしょうか。
今回は、Array()関数をネストして上記の表のような要素配列で、
二次元配列を明示的に表現するようにしました。
Excel関数に強い人なら、Evaluateメソッド（またはショートカット）で、
二次元配列を表現する方が簡素な印象はあるでしょうけれど、
誰にでも解るかどうかという点で「可読性」にArray()関数を使っています。
より複雑な処理をする場合なんかは、
CollectionオブジェクトやDictionaryオブジェクトを用いたりすることもあるでしょう。
Classモジュールについては、定義（リスト/辞書）が固定で、コード上で変更するだけなら、
必要はないですね。Typeで宣言したい、という方も居るのかも知れませんが、
却って「可読性」というか、理解され難いものになるのだと思います。

> Cat0,1ともに15個ですので下段の通り現在はMOD関数でカウンター変数の余りを求めて処理していますが、
> あまりいい処理とは思えません。
> つまり、"CRN"が16行目にあるときに実行したら、"CRN"を2行目に持ってくる（"CRT"も同様）、
> MRNが31行目にあるときに実行したら"MRN"を17行目に持ってくる、という感じです。
ここら辺を読む限りでは、
　（Visual Basic とは別の系譜に離れて５年）
　Visual Basic for Applications ユーザーとして、
　そしてExcelカテゴリへの質問であることも合わせて考えると、
お奨めするのは、.Find メソッドを軸に設計することです。
Excel の一般機能[検索]を再現する.Find メソッドでは、
「この次に見つかる」という指示だけで、最下行の次に最上行を追ってくれますから、
ループで（意図を汲み難い）工夫をする必要がない、という一点だけで、
大きく簡素化できます。
また、万が一検索結果がNothingになっていても、
エラートラップよりも簡単なやり方（Nothing判定）で、
エラー回避できる点でも、保守的に読み易く書くことに繋がります。

ご質問について、
もしも、二次元配列変数の演習という意図が含まれているのでしたら、
あらためて補足してみて下さい。
ただ、
セルの値と配列変数のやりとりにループを挟むような方法を
今回の課題については、私なら、選びません（適した場面なら寧ろ積極的な私ですが、、、）。

因みに、ですが、
修飾子mtx-は（段階配列ではない）一次元配列の場合にはあまり使われないかも、です。
Variant型、または、Variant型配列、で宣言する変数の修飾子に、
mtx-を使うのは、私を含めて小数派です。
元々は、アメリカやドイツのサイトで見かけたもので、
一次元なら、ary-やarr-、二次元または段階配列なら、mtx-、
という区別をはっきりさせる意図で使われていたものだと思います。
配列変数を多用する私が拘って、一次元か二次元かを修飾子に表しているだけで、
どちらもary-で表現するのが多数派のようですので、
（もっと言えば、配列であることすら表現しない書き手も普通に多いですし）
一応念の為。
ついでに、Option Base 1 についてですが、
複数セル範囲の値（.Value等）をVariant型に格納する場合は、
放っておいても最小の添え字は 1 になります。
また、Array()関数の場合は、Option Baseに依存、
VBA.Array()関数は、常に 0 オリジンです。
個人的には、Option Base 1 が原因で、
転用されたり、改編された時に、設計意図を汲んで貰えない、という経験が何度か
あったので、Option Base を使わず、Option Base に左右されないように書く、
というのが、最近の私の「保守」に対する考え方になりました。
やや蛇足かも、でしたね。

以下、動作確認はしましたが、ニーズに即わない場合はご指摘ください。
シートがどのような状況であっても、
とにかく次を探す、または、見つからなければ（Else以下に追記すれば別ですが）何もしません。

' ' ///
Sub ReW9093999c()
Dim Wb As Workbook, Ws As Worksheet
Dim rngMarkPos As Range, rngNewPos As Range
Dim mtxMkCat As Variant
Dim nColDiff As Long, EndRow As Long, iNA As Long

' ' 動作条件変更時の指定修正項目
Const CAT_COL = "B", MARK_COL = "I"
　　Set Wb = ThisWorkbook
　　Set Ws = Wb.Sheets("Sheet1")　'　シートの並び順（Index）での指定は避けたい（保守）
　　nColDiff = Ws.Columns(MARK_COL).Column - Ws.Columns(CAT_COL).Column
　　mtxMkCat = VBA.Array( _
　　　　　　　　　　VBA.Array("CRT", 0), _
　　　　　　　　　　VBA.Array("CRN", 0), _
　　　　　　　　　　VBA.Array("MRT", 1), _
　　　　　　　　　　VBA.Array("MRN", 1) _
　　　　　　　　　　)

' ' 以下、修正不可。
　　EndRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row
　　With Ws.Columns(MARK_COL)
　　　　For iNA = LBound(mtxMkCat) To UBound(mtxMkCat)
　　　　　　Set rngMarkPos = .Find( _
　　　　　　　　What:=mtxMkCat(iNA)(0), After:=.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, _
　　　　　　　　SearchOrder:=xlByRows, SearchDirection:=xlNext)
　　　　　　If Not rngMarkPos Is Nothing Then
　　　　　　　　Set rngNewPos = .Offset(0, -nColDiff).Find( _
　　　　　　　　　　What:=mtxMkCat(iNA)(1), After:=rngMarkPos.Offset(0, -nColDiff))
　　　　　　' Else　'　見つからないなら、、、msg ?
　　　　　　End If
　　　　　　If Not rngNewPos Is Nothing Then
　　　　　　　　rngMarkPos.ClearContents　'　元々のマークした値を消すのはココ！
　　　　　　　　rngNewPos.Offset(0, nColDiff) = mtxMkCat(iNA)(0)　'　新たにマーク値を設定する
　　　　　　　　Set rngMarkPos = Nothing:　　Set rngNewPos = Nothing
　　　　　　' Else　'　見つからないなら、、、msg ?
　　　　　　End If
　　　　Next iNA
　　End With
End Sub
' ' ///

回答No.6

real beatin（@realbeatin）

No.5、書き忘れ、追記です。

変数 Wb Ws EndRow については、
ご質問文で説明されている以外に他の処理があって、そちらで使うのかも知れない、
という意味で、ご提示の宣言と設定を踏襲していますが、
私が提示した処理内容だけであるのなら、
わざわざ変数にしなくても済むものですし、無い方が明らかに読み易いものになります。
特に EndRow は値を設定するだけで他で使われていませんから、
このままあるなら、むしろ読む方にとっては混乱の元になってしまいます。
ここで説明している理由（踏襲）以外に、これらの変数を扱う理由はありませんので、
必要かどうかの判断はお任せします。
以上です。お邪魔しました。

回答No.4

keithin

＞"CRT","CRN"についてはB列の値0の範囲内で、"MRT","MRN"についてはB列の値1の範囲内でそれを行いたい

不明１）
ＣＲＴ，ＣＲＮが最初からゼロの行に「ある」、ＭＲＴ、ＭＲＮが１の範囲にある事が前提となっているが、それは運用によって確実に保証されているのか。
もし何らかの理由でたとえばＣＲＴが１の行にあったら、どう処理したいのか。（そういうケースは考えなくて良いのか）

不明２）
ＣＲＴ，ＣＲＮをゼロの行の範囲内でぐるぐる廻したいワケだが、そもそもゼロの行は「１カタマリ」にまとまっていることが運用によって確実に保証されているのか。ゼロの行範囲が飛び飛びに２つ３つカタマリと散らばっている状況は全く想定しなくて良いのか。
１についても同じ。

sub macro1()
　dim ax as variant
　dim r as long
　dim buf as variant
　dim TargetRow as long

　for each ax in array("CRT","CRN","MRT","MRN")
　’CRT他がＪ列に「無い」ケースは想定しない
　　r = application.match(ax, range("J:J"), 0)　’今ある行
　　select case ax
　　　case "CRT", "CRN"
　　　　buf = 0
　　　case "MRT", "MRN"
　　　　buf = 1
　　end select

’次に持ってく先の行を探す
　　targetrow = range("B:B").find(what:=buf, lookin:=xlvalues, lookat:=xlwhole, searchdirection:=xlnext, after:=cells(r, "B")).row
　　cells(r, "J").clearcontents
　　cells(targetrow, "J") = ax
　next
end sub

お礼

言葉足らずで申し訳ありませんでした。
不明1,2共に、懸念の点については完璧に担保されております。

そしてFindメソッドの有用な使い方を教えていただきありがとうございます。
引数Afterで現在のセル番地を指定して、SearchDirectionをxlNextにすれば、After以降データがない場合は指定範囲内で最初のWhatの位置を検索するということなんでしょうか。
シンプルでとても分かりやすいコードです。
ご回答ありがとうございました。
とても参考になりました。

回答No.3

Prome_Lin

極めて鈍くさいですが、見た目的には、分かりやすいプログラムだと思うのですが・・・

Option Explicit

Sub Test_01()
Dim c, m, crt, crn, mrt, mrn As Integer
c = Range("B:B").Find(0, SearchDirection:=xlPrevious).Row
m = Range("B:B").Find(1, SearchDirection:=xlPrevious).Row
crt = Range("I:I").Find("CRT").Row
crn = Range("I:I").Find("CRN").Row
mrt = Range("I:I").Find("MRT").Row
mrn = Range("I:I").Find("MRN").Row
Cells(crt, 9).Value = ""
Cells(crn, 9).Value = ""
Cells(mrt, 9).Value = ""
Cells(mrn, 9).Value = ""
crn = crn + 1
If crn > c Then
crn = 2
End If
Cells(crn, 9).Value = "CRN"
crt = crt + 1
If crt > c Then
crt = 2
End If
Cells(crt, 9).Value = "CRT"
mrn = mrn + 1
If mrn > m Then
mrn = c + 1
End If
Cells(mrn, 9).Value = "MRN"
mrt = mrt + 1
If mrt > m Then
mrt = c + 1
End If
Cells(mrt, 9).Value = "MRT"
End Sub

一応、目的は達成しています。

お礼

回答ありがとうございます。
FindメソッドでCat0,1それぞれの最下行を取得し、変数に取り込んだ現在の行と比べて処理を分岐する方法ですね。

実際に使うときには"CRT","CRN","MRT","MRN"を配列に取り込んで、現在行を調べるところからFor~Next文で回したほうが良さそうなのでそのようにさせていただきます。

回答No.2

ushi2015

こんにちは
どのような感じでデータが増えるのか分からないですけど、
Catのパターンが増え、1パターンの数が15から変動し、
各Catパターンの中で判定する文字と文字数が変わるのに対応するとしたら、

Sub hoge4()
　　Dim Wb As Workbook
　　Dim Ws As Worksheet
　　Dim h As Long
　　Dim i As Long
　　Dim j As Variant
　　Dim k As Long
　　Dim r As Variant
　　Dim t 　 As Range

　　'Cat 1パターン数
　　Const Cat As Long = 15

　　'Cat パターン
　　ReDim v(1 To 5, 1 To 1)
　　v(1, 1) = "CRT,CRN"
　　v(2, 1) = "MRT,MRN"
　　v(3, 1) = "ABC,CDE"
　　v(4, 1) = "FGH,IJK,LMN"
　　v(5, 1) = "OPQ"

　　Set Wb = ThisWorkbook
　　Set Ws = Wb.Sheets(3)
　　Set t = Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp)).Offset(, 9)
　　j = t.Value

　　k = 1
　　For h = 1 To UBound(j, 1) Step Cat
　　　　For i = 1 To Cat
　　　　　　If j(h + i - 1, 1) <> "" Then
　　　　　　　　r = InStr(1, v(k, 1), j(h + i - 1, 1))
　　　　　　　　If r > 0 Then
　　　　　　　　　　If h + i - 1 = Cat * k Then
　　　　　　　　　　　　j(h, 1) = j(h + i - 1, 1)
　　　　　　　　　　　　j(h + i - 1, 1) = ""
　　　　　　　　　　Else
　　　　　　　　　　　　j(h + i, 1) = j(h + i - 1, 1)
　　　　　　　　　　　　j(h + i - 1, 1) = ""
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　　　k = k + 1
　　Next h

　　Application.ScreenUpdating = False
　　t.Value = j
　　Application.ScreenUpdating = False
End Sub

とかでしょうか？

お礼

ありがとうございます。
配列内で処理することにより、書式設定の問題もクリアされています。
助かりました。

回答No.1

ushi2015

こんにちは
データは何かしらのパターンで増えるのですか？
Ws.Range("A1:AO" & EndRow).Value = mtxNI
は、
Ws.Range("A1:Ｊ" & EndRow).Value = mtxNI
の間違いでしょうか？

どこが、あまりいい処理とは思えないのか分かりませんし、
どのようなコードが適しているのかも良く分かりませんし、
何故、クラスモジュールの話がでてくるのかも良く分かりません。

色々な方法が有るとは思いますけど、
Sub hoge3()
　　Dim Wb As Workbook
　　Dim Ws As Worksheet
　　Dim j As Range
　　Dim t As Range
　　Dim r As Range

　　Set Wb = ThisWorkbook
　　Set Ws = Wb.Sheets(3)

　　Set j = Ws.Range("J:J")
　　Ws.Range("J1").Insert xlShiftDown

　　On Error Resume Next
　　Set t = j.SpecialCells(xlCellTypeConstants)
　　On Error GoTo 0

　　If t Is Nothing Then Exit Sub

　　Application.ScreenUpdating = False
　　For Each r In t
　　　　Select Case r.Value
　　　　　　Case "CRT", "CRN"
　　　　　　　　If r.Row > 16 Then
　　　　　　　　　　j(2, 1) = r.Value
　　　　　　　　　　r.Value = ""
　　　　　　　　End If
　　　　　　Case "MRT", "MRN"
　　　　　　　　If r.Row > 31 Then
　　　　　　　　　　j(17, 1) = r.Value
　　　　　　　　　　r.Value = ""
　　　　　　　　End If
　　　　　　Case Else

　　　　End Select
　　Next r
　　Application.ScreenUpdating = False
End Sub
とかも。

お礼

ありがとうございます。
J1セルを挿入して一つ下にずらしてから処理する方法ですね。
書式設定ごとずれるのでその処理が必要になるかと思いますが、動作確認できました。

あまりいい処理とは思えない理由は、Cat0,1共に同数でなければならない制約がつきますし、仰るようにデータ自体が増える可能性があるので、その際にコード書き直すことになるなぁ、というところです。
Cat0,1の最上行と最下行を変数に取り込んで処理するしかないのかなと思っているのですが、もっと平易というか、保守性が高く、無駄のない、可読性に優れたコードが無いものかと思い、質問させていただきました。
クラスモジュールの件は、私自身がまったくそれを理解しておらず、以前に読んだクラスモジュールの説明でおぼろげに、こういう処理に適しているのかと思っただけですので的外れなようであればご放念ください。