| |
▼ｄ46 さん
おはようございます。
これで安心しました。
再投稿です。
新規ブックの標準モジュールに
'============================================================
Option Explicit
Sub main()
Dim g0 As Long
Dim ans As Variant
Dim rng As Range
ReDim 初期値(1 To 1) As Long
Set rng = Range("a1", Cells(Rows.Count, "a").End(xlUp))
Set rng = rng.Resize(rng.Rows.Count - 1)
With rng
.Offset(0, 1).NumberFormatLocal = "@"
.Offset(0, 1).Value = ""
End With
g0 = 1
初期値(1) = 5 '初期値の設定
Call open_nestnum(rng, 初期値())
ans = get_nestnum
Do Until ans = ""
rng.Cells(g0).Offset(0, 1).Value = ans
g0 = g0 + 1
ans = get_nestnum
Loop
Call close_nestnum
End Sub
別の標準モジュールに
'===============================================================
Option Explicit
Dim lblcnum() As Long '各レベルの数値
Dim f_val As Variant '初期値の配列
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 Variant = 1, Optional ByVal kt As Long = 3)
' 索引的数値配置処理の内部データの初期化
' Input: rng
' レベル指示を格納したセル範囲
' （ただし、一つの行、または、列に存在する連続したセル範囲に限る)
' 例 A1:A5 a1:z1
' f_value レベルの初期数値を配列で指定する f_value(1) レベル1の初期値 f_value(2) レベル2の初期値
' 省略すると 全て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
If TypeName(f_value) = "Integer" Then
f_value = Array(0, 1)
End If
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
sb_lbl = False
End Sub
'===============================================================
Function get_nestnum() As Variant
'配列inarray()の指示による索引的数値配置を返す
' input なし
' get_nestnum 索引的数値配置 ""の場合、データの終わり
On Error Resume Next
Dim g0 As Long
Dim d_data As Variant
Dim wk As Long
get_nestnum = ""
If inidx <= UBound(inarray()) Then
d_data = Val(inarray(inidx))
If d_data > 0 Then
sb_lbl = False
Else
If sb_lbl = False Then
d_data = clbl + 1
Else
d_data = clbl
End If
sb_lbl = True
End If
ReDim Preserve lblcnum(1 To d_data)
For g0 = LBound(lblcnum()) To UBound(lblcnum())
If lblcnum(g0) = 0 Then
Err.Clear
wk = f_val(g0)
If Err.Number <> 0 Then
wk = 1
End If
lblcnum(g0) = wk
End If
Next
If d_data <= clbl Then
lblcnum(d_data) = lblcnum(d_data) + 1
Else
Err.Clear
wk = f_val(d_data)
If Err.Number <> 0 Then
wk = 1
End If
lblcnum(d_data) = wk
End If
clbl = d_data
For g0 = 1 To clbl
get_nestnum = get_nestnum & _
Format(lblcnum(g0), String(d_keta, "0"))
Next
inidx = inidx + 1
End If
End Function
としてください。
アクティブシートのデータが
Ａ Ｂ
１ 1
２ 2
３
４ 1
５ End
このようなデータで
Ａ Ｂ
１ 1 005
２ 2 005001
３ 005001001
４ 1 006
５ end
となります。
（必ず、最終行を示す「end」を入れること）
確認してください。
尚、この後の投稿は夜以降になってしまいます。
|
|
ichinose
- 06/8/29(火) 9:49 -
