遡り位置を表記する。

エクセルの I1~L1 　千　百　十　一 と　各列の位名が入力されています。
その下 I2～L2710に　0～9までの数字が、ランダムで入力してあります。

千百十一
３３６５
８５９２
１１１１
４４８８
４１０1
１１７６
３３５０
７２５６
１６９８
５８６６
７６２２
・・・・
・・・・
・・・・
....2710行


検索開始対象数字は I12 ～ L12 、上の表でみるなら ＜ 7 6 2 2 ＞ に あたります。
この数字を位別(列)に見て検索し、右列 M12 ～ U12 に ＜ 何個前に対象数字があるか？＞ を位別に表記したいのです。
これを、2720行まで行います。

検索をするにあたり
①. 遡るのは10個前までです。各位の検査結果は
千 → M12 , 百 → O12 , 十 → Q12 , 一 → S12　に入力し、無ければ "X" とします。
②.①で "X" だった場合 各 M,O,Q,S の右隣の列(N,P,R,U)に、下の順番で検索

　　千の場合　千 → 百 → 十 → 一
　　百の場合　百 → 十 → 一 → 千
　　十の場合　十 → 一 → 千 → 百
　　一の場合　一 → 千 → 百 → 十
を行い、＜どの位置(千・百・十・一)の何個前に該当数字はあたるのか？＞を表記します。
③. 2を行い、検索しても無い場合は "X" と表記します。
　 　
※この7622の場合は、
千の位にある"7"は、3個前にあるので → M12→"3", N12→"X"
百の位にある"6"は、2個前にあるので→ O12→"2", P12→”X”
十の位にある"2"は、10個遡ってもありません。
なので右隣の一の位へ…。すると一の位の9個前にあるので → Q12→”X" , R12→”一,9”
一の位にある"2"は、9個前にあるので → S12→"9" , T12→"X"
となる表を作成したいのです。
※(千・百・十・一)の表記が難しい場合（あ・い・う・え）でも構いません。

調べ記載したい行が、I12～から始まりL2710まで、、、約3000行弱の数字を一個づつ調べるのは大変で、とても困っています。
良い方法は、無いでしょうか？？？

何卒、お力をお貸しください！！
よろしくお願いいたします。

質問者からの補足コメント

• 該当数字が無い場合の　訂正をさせてください！！
  該当数字が無い場合は、一回前→二回前→三回前・・・・と十回前まで遡り、
  
  一回前　千 → 百 → 十 → 一
  二回前　千 → 百 → 十 → 一
  三回前　千 → 百 → 十 → 一　・・・・
  
  と、より近い所で該当する数字は＜どの位,何回前＞としたいのです。
  なので " 7622 " の十の位の場合は、一番近いのが、百の位の三回前にあたりますので
  → Q12→”X" , R12→”百,3”と表記したいです。
  また、同じ回に該当する数字が二個以上入っている場合は、優先順位を
  千 → 百 → 十 → 一
  として表記したいのです。

    補足日時：2016/02/11 13:07

No.3 ベストアンサー 回答者： siffon9 回答日時： 2016/02/11 16:34

No.1です、

> 各列に無い場合②の作業を行う指定を"本文"のやり方から"補足コメント"記載のように変更したいのです。

その様にしたつもりなのですが……仕様について理解しきれていないのかもしれません。


> " 7622 " の十の位の場合は、一番近いのが、百の位の三回前にあたりますので→ Q12→”X" , R12→”百,3”と表記したいです。

となっていませんか？

私の理解に間違いがあるかもしれませんので、
質問欄に提示していただいたデータで、具体的に実行結果がこうなっているけど、こうして欲しいという様にご提示いただけないでしょうか？

この回答へのお礼

有難うございます！！
助かりました！！

お礼日時：2016/02/11 17:01

No.2 回答者： 30246kiku 回答日時： 2016/02/11 16:33

以下でどうなりますか

提示されたデータはナンバーズの様ですが、
VBA での処理サンプルだということで･･･

なお、同列１０行前まで見つからなかった場合、
直近に見つかったものを表示していますが、
添付図赤印の様に、直近の場合は１０行のリミットを外してました
リミット判別する際には ★ 部分変更してください

Public Sub Samp1()
　　Dim dic(1 To 4) As Object, dicN As Object
　　Dim vA As Variant, vB As Variant, v As Variant
　　Dim i As Long, j As Long, k As Long, n As Long

　　Set dicN = CreateObject("Scripting.Dictionary")
　　With Range("I1", Cells(Rows.Count, "I").End(xlUp))
　　　　vA = .Resize(, 4).Value
　　End With
　　ReDim vB(1 To UBound(vA) - 11, 1 To 8)
　　For j = 1 To 4
　　　　Set dic(j) = CreateObject("Scripting.Dictionary")
　　Next
　　k = 2
　　While (k < 12)
　　　　For j = 4 To 1 Step -1
　　　　　　dic(j)(vA(k, j)) = k
　　　　　　dicN(vA(k, j)) = Array(j, k)
　　　　Next
　　　　k = k + 1
　　Wend

　　For i = k To UBound(vA)
　　　　For j = 1 To 4
　　　　　　n = (j - 1) * 2 + 1
　　　　　　k = dic(j)(vA(i, j))
　　　　　　If (i - k <= 10) Then
　　　　　　　　vB(i - 11, n) = i - k
　　　　　　　　vB(i - 11, n + 1) = "×"
　　　　　　Else
　　　　　　　　vB(i - 11, n) = "×"
　　　　　　　　v = dicN(vA(i, j))
　　　　　　　　If (IsArray(v)) Then
　　　　　　　　　　vB(i - 11, n + 1) = _
　　　　　　　　　　　　vA(1, v(0)) & "," & i - v(1) ' ★
　　　　　　　　Else
　　　　　　　　　　vB(i - 11, n + 1) = "×"
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　For j = 4 To 1 Step -1
　　　　　　dic(j)(vA(i, j)) = i
　　　　　　dicN(vA(i, j)) = Array(j, i)
　　　　Next
　　Next

　　With Range("M12").Resize(UBound(vB), 8)
　　　　.Value = vB
　　End With

　　Set dicN = Nothing
　　For j = 1 To 4
　　　　Set dic(j) = Nothing
　　Next
End Sub

上記では、各列に出現したものの最新行番号を更新し覚える様にしてました
それ用に Dictionary を用いたわけですが、実際 I:L 列の値は何でも良いです
0 ～ 9 の値ではなく、A, B, C ･･･ でも
数値に限定するのなら Dictionary ではなく、配列でも･･･
以下は配列を使った例になるか？･･･

Public Sub Samp2()
　　Dim iA(1 To 4, 0 To 9) As Long
　　Dim iB(0 To 9, 1 To 2) As Long
　　Dim vA As Variant, vB As Variant
　　Dim i As Long, j As Long, k As Long, n As Long

　　With Range("I1", Cells(Rows.Count, "I").End(xlUp))
　　　　vA = .Resize(, 4).Value
　　End With
　　ReDim vB(1 To UBound(vA) - 11, 1 To 8)
　　k = 2
　　While (k < 12)
　　　　For j = 4 To 1 Step -1
　　　　　　iA(j, vA(k, j)) = k
　　　　　　iB(vA(k, j), 1) = j
　　　　　　iB(vA(k, j), 2) = k
　　　　Next
　　　　k = k + 1
　　Wend

　　For i = k To UBound(vA)
　　　　For j = 1 To 4
　　　　　　n = (j - 1) * 2 + 1
　　　　　　k = iA(j, vA(i, j))
　　　　　　If (i - k <= 10) Then
　　　　　　　　vB(i - 11, n) = i - k
　　　　　　　　vB(i - 11, n + 1) = "×"
　　　　　　Else
　　　　　　　　vB(i - 11, n) = "×"
　　　　　　　　If ((iB(vA(i, j), 1) > 0) _
　　　　　　　　　　And (iB(vA(i, j), 2) > 0)) Then
　　　　　　　　　　vB(i - 11, n + 1) = _
　　　　　　　　　　　　vA(1, iB(vA(i, j), 1)) & "," _
　　　　　　　　　　　　& i - iB(vA(i, j), 2)
　　　　　　　　Else
　　　　　　　　　　vB(i - 11, n + 1) = "×"
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　For j = 4 To 1 Step -1
　　　　　　iA(j, vA(i, j)) = i
　　　　　　iB(vA(i, j), 1) = j
　　　　　　iB(vA(i, j), 2) = i
　　　　Next
　　Next

　　With Range("M12").Resize(UBound(vB), 8)
　　　　.Value = vB
　　End With
End Sub



※　L2710までに限定するなら

>　　With Range("I1", Cells(Rows.Count, "I").End(xlUp))
↓
　　With Range("I1").Resize(2710)

にしてみてください

この回答へのお礼

試行しました。
素晴らしい表が完成いたしました！！
有難うございます！！！！！

お礼日時：2016/02/11 17:01

No.1 回答者： siffon9 回答日時： 2016/02/11 15:42

こんな感じでしょうか？

動作に勘違いがありましたらスミマセン。

Sub test()
Dim cRng As Range
Dim dRng As Range
Dim rOffst As Long
Dim col As Long
Dim s As String
Dim notFound As String: notFound = "X"


For Each cRng In Range("I2:L2710") '確認範囲
' 結果を書くセル
Set dRng = Cells(cRng.row, 13 + 2 * (cRng.Column - 9))
' 同じ列を検索
rOffst = searchRow(cRng.Value, cRng)
If rOffst <> 0 Then
'同じ列に見つかった場合
dRng.Value = -1 * rOffst
dRng.offset(0, 1).Value = notFound
Else
dRng.Value = notFound
' I列 to L列のcRngと異なる列を検索
For col = 9 To 12 ' I列 to L列
If col = cRng.Column Then GoTo L_CONTINUE
rOffst = searchRow(cRng.Value, Cells(cRng.row, col))
If rOffst <> 0 Then
s = Cells(1, col).Value & "," & (-1 * rOffst)
dRng.offset(0, 1).Value = s
Exit For
End If
dRng.offset(0, 1).Value = notFound
L_CONTINUE:
Next col
End If
Next cRng
MsgBox "end"
End Sub

' baseから10個前までに同じ値があれば、そのrow offsetを返す。
' なければ 0を返す。
Function searchRow(val As Long, base As Range) As Long
Dim i As Long
searchRow = 0
For i = -1 To -10 Step -1
If base.row + i = 1 Then
Exit For
End If
If CLng(base.offset(i, 0).Value) = val Then
searchRow = i
Exit Function
End If
Next
End Function

この回答へのお礼

お知恵を貸していただき有難うございます！！
バッチリ！本文通りの動作確認いたしました！！
ただ、各列に無い場合②の作業を行う指定を"本文"のやり方から"補足コメント"記載のように変更したいのです。
勝手を申し上げ、大変恐縮ですが、②の作業を補足コメントのように変更できませんでしょうか？

お礼日時：2016/02/11 16:03