Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


39826 / 76732 ←次へ | 前へ→

【42012】Re:[41980]の返答です。
発言  ichinose  - 06/8/29(火) 9:49 -

引用なし
パスワード
   ▼d46 さん
おはようございます。

これで安心しました。

再投稿です。

新規ブックの標準モジュールに
'============================================================
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


としてください。


アクティブシートのデータが

       A    B
 1     1
 2     2
 3     
 4     1
 5    End

このようなデータで
     A   B
 1   1   005
 2   2   005001
 3       005001001
 4   1   006
 5   end

となります。
(必ず、最終行を示す「end」を入れること)


確認してください。

尚、この後の投稿は夜以降になってしまいます。
1 hits

【41903】自動で番号を振るには d46 06/8/25(金) 18:01 質問
【41908】Re:自動で番号を振るには かみちゃん 06/8/25(金) 19:51 発言
【41947】Re:自動で番号を振るには ichinose 06/8/26(土) 16:51 発言
【41964】補足です。 d46 06/8/27(日) 10:35 発言
【41966】Re:自動で番号を振るには(ツリー形式の階... かみちゃん 06/8/27(日) 10:58 発言
【41976】Re:補足です。 [名前なし] 06/8/27(日) 17:09 発言
【41978】Re:補足です。 d46 06/8/27(日) 20:18 発言
【41979】Re:自動で番号を振るには(ツリー形式の階... かみちゃん 06/8/27(日) 20:27 発言
【41980】Re:自動で番号を振るには(ツリー形式の階... ichinose 06/8/27(日) 21:34 発言
【41985】すごいです!! d46 06/8/28(月) 9:28 お礼
【41988】再度質問 d46 06/8/28(月) 13:06 質問
【41995】Re:再度質問 d46 06/8/28(月) 16:14 発言
【42002】Re:再度質問 ichinose 06/8/28(月) 20:03 発言
【42007】[41980]の返答です。 d46 06/8/29(火) 8:39 発言
【42012】Re:[41980]の返答です。 ichinose 06/8/29(火) 9:49 発言
【42013】Re:[41980]の返答です。 d46 06/8/29(火) 10:14 お礼

39826 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free