Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
10454 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【21786】採番 Y 05/1/30(日) 15:37 質問[未読]
【21787】Re:採番 kobasan 05/1/30(日) 16:06 回答[未読]
【21788】Re:採番 かみちゃん 05/1/30(日) 16:10 回答[未読]
【21789】Re:採番 Y 05/1/30(日) 16:28 質問[未読]
【21790】Re:採番 かみちゃん 05/1/30(日) 16:45 回答[未読]
【21791】Re:採番 Y 05/1/30(日) 17:11 質問[未読]
【21792】Re:採番 かみちゃん 05/1/30(日) 17:24 回答[未読]
【21793】Re:採番 ｂｙｋｉｎ 05/1/30(日) 18:34 回答[未読]
【21794】Re:採番 Y 05/1/30(日) 20:04 お礼[未読]
【21795】Re:採番 かみちゃん 05/1/30(日) 20:12 回答[未読]
【21786】採番
質問  Y  - 05/1/30(日) 15:37 -
引用なし
パスワード
   　　　列　A　　B
　　行　　NO1　NO２　　
　　１　　１　　２　　　
　　２　　２　　５　
　　３　　３　　３
　　４　　４　　４
　　５　　５　　２
現在以上の用にエクセル表があるとして、
以下のようにする為のマクロはどうしたらいいのでしょうか？。本当はNO1が250個並んでいる状態です。また、NO２の数字が変わっていく可能性がある為、何度もするのはとてもできそうもない状態です。お願いします。

　　列　　A　　B　　C
　行　　NO1　 NO2　NO3
　1　　 1　　 2　　1
　2　　 1　　 2　　2
　3　　 2　　 5　　1
　4　　 2　　 5　　2
　5　　 2　　 5　　3
　6　　 2　　 5　　4
　7　　 2　　 5　　5
　8　　 3　　 3　　1
　9　　 3　　 3　　2
10　　 3　　 3　　3
11　　 4　　 4　　1
12　　 4　　 4　　2
13　　 4　　 4　　3
14　　 4　　 4　　4
15　　 5　　 2　　1
16　　 5　　 2　　2
17　　 6　 続く
【21787】Re:採番
回答  kobasan  - 05/1/30(日) 16:06 -
引用なし
パスワード
   ▼Y さん今日は
【21768】並び替えのキーの数について みゆ 05/1/29(土) 1:15　
の質問に対する答えからでいいとおもいますが
【21788】Re:採番
回答  かみちゃん  - 05/1/30(日) 16:10 -
引用なし
パスワード
   こんにちは。かみちゃん　です。

>以下のようにする為のマクロはどうしたらいいのでしょうか？

以下のような感じでできると思います。
ただし、Excelの最大行を超えたときの処理などは考慮していません。

Option Explicit
Sub Macro1()
　Dim RowNo, RowNo2 As Long
　
　RowNo = 1
　Do While Cells(RowNo, 1).Value <> ""
　　Rows(RowNo).Copy
　　Rows(RowNo + 1 & ":" & RowNo + Cells(RowNo, 2) - 1).Insert Shift:=xlDown
　　For RowNo2 = 1 To Cells(RowNo, 2)
　　　Cells(RowNo + RowNo2 - 1, 3) = RowNo2
　　Next
　　
　　RowNo = RowNo + Cells(RowNo, 2)
　Loop
　Application.CutCopyMode = False
　Range("A1").Select
End Sub
【21789】Re:採番
質問  Y  - 05/1/30(日) 16:28 -
引用なし
パスワード
   デバックでてしまいましたが・・・。
ちなみに、NO1、NO２列とも数字は規則性がございません。
ご対処よろしくお願い申し上げます。

▼かみちゃん さん：
>こんにちは。かみちゃん　です。
>
>>以下のようにする為のマクロはどうしたらいいのでしょうか？
>
>以下のような感じでできると思います。
>ただし、Excelの最大行を超えたときの処理などは考慮していません。
>
>Option Explicit
>Sub Macro1()
>　Dim RowNo, RowNo2 As Long
>　
>　RowNo = 1
>　Do While Cells(RowNo, 1).Value <> ""
>　　Rows(RowNo).Copy
>　　Rows(RowNo + 1 & ":" & RowNo + Cells(RowNo, 2) - 1).Insert Shift:=xlDown
>　　For RowNo2 = 1 To Cells(RowNo, 2)
>　　　Cells(RowNo + RowNo2 - 1, 3) = RowNo2
>　　Next
>　　
>　　RowNo = RowNo + Cells(RowNo, 2)
>　Loop
>　Application.CutCopyMode = False
>　Range("A1").Select
>End Sub
【21790】Re:採番
回答  かみちゃん  - 05/1/30(日) 16:45 -
引用なし
パスワード
   こんにちは。かみちゃん　です。

>デバックでてしまいましたが・・・。
>ちなみに、NO1、NO２列とも数字は規則性がございません。

どういうエラーがどの行で出ているのでしょうか？
もちろん、動作確認済みです。
なお、処理対象が１行目からの場合に対応しているので、２行目以降から開始した
い場合は、
RowNo = 1
を適宜修正してください。
【21791】Re:採番
質問  Y  - 05/1/30(日) 17:11 -
引用なし
パスワード
   2行目からなので、
rowNO = 2
として、したところ、延々と処理が終わらなくなりました・・。

▼かみちゃん さん：
>こんにちは。かみちゃん　です。
>
>>デバックでてしまいましたが・・・。
>>ちなみに、NO1、NO２列とも数字は規則性がございません。
>
>どういうエラーがどの行で出ているのでしょうか？
>もちろん、動作確認済みです。
>なお、処理対象が１行目からの場合に対応しているので、２行目以降から開始した
>い場合は、
> RowNo = 1
>を適宜修正してください。
【21792】Re:採番
回答  かみちゃん  - 05/1/30(日) 17:24 -
引用なし
パスワード
   こんにちは。かみちゃん　です。

>延々と処理が終わらなくなりました・・。

ご提示されたサンプルで、まずは試されましたか？
ただし、No2の値に1が入ると、無限ループ（延々と処理が終わらないこと）になります。
従いまして、1が入っている場合を考慮すると、以下の★部分を追加してください。
なお、No2の値が0以下の場合、整数以外の数値、文字列の場合は考慮していません。

Option Explicit
Sub Macro1()
　Dim RowNo, RowNo2 As Long

　'2行目より処理を開始します。
　RowNo = 2
　Do While Cells(RowNo, 1).Value <> ""
　　'No2の値が1よりも大きいとき
　　If Cells(RowNo, 2).Value > 1 Then '★
　　　Rows(RowNo).Copy
　　　Rows(RowNo + 1 & ":" & RowNo + Cells(RowNo, 2) - 1).Insert Shift:=xlDown
　　　For RowNo2 = 1 To Cells(RowNo, 2)
　　　　Cells(RowNo + RowNo2 - 1, 3) = RowNo2
　　　Next
　　Else '★
　　　'No2の値が1以下の場合
　　　'ただし、0はないものとする。
　　　Cells(RowNo, 3) = 1 '★
　　End If '★
　　RowNo = RowNo + Cells(RowNo, 2)
　Loop
　Application.CutCopyMode = False
　Range("A1").Select
End Sub
【21793】Re:採番
回答  ｂｙｋｉｎ  - 05/1/30(日) 18:34 -
引用なし
パスワード
   こんにちわ。

ループで行の挿入や削除をやるときは、下からやったほうが簡単やと思うんやけど・・・
で、数式入れる方法で一案考えてみました。
結果は新しいシートを追加してそこに書き出してます。

Sub test()
　　Dim i As Long
　　
　　Application.ScreenUpdating = False
　　ActiveSheet.Copy ActiveSheet
　　For i = Range("A65536").End(xlUp).Row To 2 Step -1
　　　　If Cells(i, 2).Value > 1 Then
　　　　　　Rows(i).Copy
　　　　　　Range(Rows(i + 1), Rows(i + Cells(i, 2).Value - 1)).Insert
　　　　End If
　　Next
　　Range("C2").Value = 1
　　With Range(Cells(3, 3), Range("A65536").End(xlUp).Offset(0, 2))
　　　　.Formula = "=IF(A3=A2,C2+1,1)"
　　　　.Value = .Value
　　End With
　　Range("A1:B1").AutoFill Range("A1:C1")
　　Application.ScreenUpdating = True
End Sub

Ｃ１の項目名がＡ１：Ｂ１のオートフィルでは具合悪いんやったら、
直接指定してください。

試してみてな。
ほな。
【21794】Re:採番
お礼  Y  - 05/1/30(日) 20:04 -
引用なし
パスワード
   かみちゃんさんへ
大変ありがとうございました！！！
できました。
今後のために、N行目から始める場合は、
どこを修正すればよろしいのでしょうか？
ご教示お願い申し上げます。

▼かみちゃん さん：
>こんにちは。かみちゃん　です。
>
>>延々と処理が終わらなくなりました・・。
>
>ご提示されたサンプルで、まずは試されましたか？
>ただし、No2の値に1が入ると、無限ループ（延々と処理が終わらないこと）になります。
>従いまして、1が入っている場合を考慮すると、以下の★部分を追加してください。
>なお、No2の値が0以下の場合、整数以外の数値、文字列の場合は考慮していません。
>
>Option Explicit
>Sub Macro1()
>　Dim RowNo, RowNo2 As Long
>
>　'2行目より処理を開始します。
>　RowNo = 2
>　Do While Cells(RowNo, 1).Value <> ""
>　　'No2の値が1よりも大きいとき
>　　If Cells(RowNo, 2).Value > 1 Then '★
>　　　Rows(RowNo).Copy
>　　　Rows(RowNo + 1 & ":" & RowNo + Cells(RowNo, 2) - 1).Insert Shift:=xlDown
>　　　For RowNo2 = 1 To Cells(RowNo, 2)
>　　　　Cells(RowNo + RowNo2 - 1, 3) = RowNo2
>　　　Next
>　　Else '★
>　　　'No2の値が1以下の場合
>　　　'ただし、0はないものとする。
>　　　Cells(RowNo, 3) = 1 '★
>　　End If '★
>　　RowNo = RowNo + Cells(RowNo, 2)
>　Loop
>　Application.CutCopyMode = False
>　Range("A1").Select
>End Sub
【21795】Re:採番
回答  かみちゃん  - 05/1/30(日) 20:12 -
引用なし
パスワード
   こんにちは。かみちゃん　です。

>今後のために、N行目から始める場合は、
>どこを修正すればよろしいのでしょうか？

>>　'2行目より処理を開始します。
>>　RowNo = 2

とコメントを記述のとおりです。
これでわからなければ、再度おたずねください。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
10454 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free