| |
こんにちは。
>>A列に番号が振ってあり規則に従いB列に番号(文字列)を振りたいのです。
>その規則とは何ですか？説明していただけないでしょうか？
と かみちゃんさんがおっしゃっているように
例が一つでは足りないくらい規則が複雑ですよね！！
暇な土曜日だったのでわからない仕様は独断と偏見で決めましたが、
こういう場合は、最低３つは例を上げてくださいね。
新規ブックの標準モジュールに
'==================================================================
Sub main()
Dim g0 As Long
Dim ans As Variant
Dim rng As Range
With ActiveSheet
.Range("a:a").NumberFormatLocal = "G/標準"
.Range("b:b").NumberFormatLocal = "@"
.Range("a1:a9").Value = _
Application.Transpose(Array(1, 2, "", "", 2, 3, "", 1, 2))
.Range("b:b").Value = ""
g0 = 1
Call open_nestnum(.Range("a1:a9"))
ans = get_nestnum
Do Until ans = ""
.Range("a1:a9").Cells(g0).Offset(0, 1).Value = ans
g0 = g0 + 1
ans = get_nestnum
Loop
Call close_nestnum
MsgBox "例1 確認してください"
.Range("a1:a10").Value = _
Application.Transpose(Array(1, 2, "", "", 1, 2, "", "", 2, ""))
.Range("b:b").Value = ""
g0 = 1
Call open_nestnum(.Range("a1:a10"))
ans = get_nestnum
Do Until ans = ""
.Range("a1:a10").Cells(g0).Offset(0, 1).Value = ans
g0 = g0 + 1
ans = get_nestnum
Loop
Call close_nestnum
MsgBox "例2 確認してください"
End With
End Sub
別の標準モジュールに
'=====================================================================
Dim lblcnum() As Long '各レベルの数値
Dim f_val As Long '初期値
Dim d_keta As Long '数値表示桁数
Dim clbl As Long '現在の最終レベル
Dim inidx As Long '配列inarray()のカレントポインタ
Dim inarray() As Variant 'レベル指示配列
Dim sb_lbl As Boolean
'↑配列inarray()の空白の連続性を示す True 一つ前の要素も空白 False 一つ前の要素も空白ではない
'=====================================================================
Sub open_nestnum(rng As Range, Optional ByVal f_value As Long = 1, Optional ByVal kt As Long = 3)
' 索引的数値配置処理の内部データの初期化
' Input: rng
' レベル指示を格納したセル範囲
' （ただし、一つの行、または、列に存在する連続したセル範囲に限る)
' 例 A1:A5 a1:z1
' f_value レベルの初期数値（規定値 1）
' kt 各レベルの表示桁数（規定値3）3の場合、
' 001 002というような3桁表示になる
Dim g0 As Long
Erase lblcnum()
Erase inarray()
ReDim inarray(1 To rng.Count)
For g0 = 1 To rng.Count
inarray(g0) = rng.Cells(g0).Value
Next
f_val = f_value
d_keta = kt
clbl = 0
inidx = 1
sb_lbl = False
End Sub
'=====================================================================
Sub close_nestnum()
' 索引的数値配置処理の終了処理 内部で使用している配列の初期化
Erase lblcnum()
Erase inarray()
f_val = 0
d_keta = 0
clbl = 0
inidx = 0
End Sub
'=====================================================================
Function get_nestnum() As Variant
'配列inarray()の指示による索引的数値配置を返す
' input なし
' get_nestnum 索引的数値配置 ""の場合、データの終わり
On Error Resume Next
Dim g0 As Long
Dim wk As Long
get_nestnum = ""
If inidx <= UBound(inarray()) Then
If IsNumeric(inarray(inidx)) And inarray(inidx) <> "" Then
sb_lbl = False
wk = lblcnum(inarray(inidx))
If Err.Number <> 0 Then
ReDim Preserve lblcnum(1 To inarray(inidx))
For g0 = LBound(lblcnum()) To UBound(lblcnum())
If lblcnum(g0) = 0 Then
lblcnum(g0) = f_val
End If
Next
clbl = inarray(inidx)
Else
If inarray(inidx) <= clbl Then
lblcnum(inarray(inidx)) = wk + 1
Else
lblcnum(inarray(inidx)) = f_val
End If
clbl = inarray(inidx)
End If
Else
If sb_lbl = False Then
clbl = clbl + 1
End If
wk = lblcnum(clbl)
If Err.Number <> 0 Then
ReDim Preserve lblcnum(1 To clbl)
For g0 = LBound(lblcnum()) To UBound(lblcnum())
If lblcnum(g0) = 0 Then
lblcnum(g0) = f_val
End If
Next
Else
If sb_lbl = True Then
lblcnum(clbl) = wk + 1
Else
lblcnum(clbl) = f_val
End If
End If
sb_lbl = True
End If
get_nestnum = ""
For g0 = 1 To clbl
get_nestnum = get_nestnum & Format(lblcnum(g0), String(d_keta, "0"))
Next
inidx = inidx + 1
End If
End Function
として、mainを実行してください。
２種類のＡ列の例から、Ｂ列に番号を振っています。
確認してみてください。
|
|
ichinose
- 06/8/26(土) 16:51 -
