Excel VBA質問箱 IV

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

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


4576 / 13644 ツリー ←次へ | 前へ→

【55845】特定の行を、任意の複数箇所に挿入・コピーする方法 taro 08/5/21(水) 11:32 質問[未読]
【55846】Re:特定の行を、任意の複数箇所に挿入・コ... テト 08/5/21(水) 11:54 発言[未読]
【55853】Re:特定の行を、任意の複数箇所に挿入・コ... taro 08/5/21(水) 13:47 発言[未読]
【55855】Re:特定の行を、任意の複数箇所に挿入・コ... テト 08/5/21(水) 13:56 発言[未読]
【55860】Re:特定の行を、任意の複数箇所に挿入・コ... taro 08/5/21(水) 14:18 お礼[未読]
【55849】Re:特定の行を、任意の複数箇所に挿入・コ... kanabun 08/5/21(水) 13:29 発言[未読]
【55852】Re:特定の行を、任意の複数箇所に挿入・コ... taro 08/5/21(水) 13:46 発言[未読]
【55859】Re:特定の行を、任意の複数箇所に挿入・コ... kanabun 08/5/21(水) 14:11 発言[未読]
【55861】Re:特定の行を、任意の複数箇所に挿入・コ... taro 08/5/21(水) 14:19 お礼[未読]

【55845】特定の行を、任意の複数箇所に挿入・コピ...
質問  taro  - 08/5/21(水) 11:32 -

引用なし
パスワード
   いきなりの具体例で恐縮です。
例えば、以下のような表があるとします。

  A       B   C  
1 表タイトル1
2 表タイトル2
3 整理番号   項目1 項目2 
4 21       --  -- 
5 21       --  -- 
6 22       --  --
7 22       --  --
8 23       --  --
9 23       --  --

このとき、A列(整理番号)が変わる行を境に、1・2行目(表タイトル1・
表タイトル2)を行ごと挿入コピーしたい場合、どのようにマクロを書けば
いいでしょうか。
上の例では、
 * 5行目と6行目の間に、1・2行目を行の挿入・コピーをする
 * 7行目と8行目の間に、1・2行目を行の挿入・コピーをする
ということになります。

なお、他の前提条件は以下のとおりです。
 * 21・22・23の整理番号は、この3つだけでなく約20種類あること
 * それぞれの整理番号の行数は、整理番号によって異なること
 * 毎月1回の更新処理を想定していて、同じ整理番号でも月によって
   行数は変動すること

丸投げのような質問で恐縮ですが、どなたかご教授いただければ
幸いです。
よろしくお願いいたします。

【55846】Re:特定の行を、任意の複数箇所に挿入・...
発言  テト  - 08/5/21(水) 11:54 -

引用なし
パスワード
   こんなのどう?

――――――――――――――――――――――――――――――
Dim iRow As Long

Application.ScreenUpdating = False

For iRow = 4 To Range("A1").End(xlDown).Row
  With Range("A" & iRow)
    If .Value = .Offset(-1).Value Then
      Range("A1:A2").EntireRow.Copy
      .Offset(1).EntireRow.Insert xlDown
      iRow = iRow + 1
    End If
  End With
Next iRow

Application.ScreenUpdating = True
Application.CutCopyMode = xlCopy
――――――――――――――――――――――――――――――

【55849】Re:特定の行を、任意の複数箇所に挿入・...
発言  kanabun  - 08/5/21(水) 13:29 -

引用なし
パスワード
   >例えば、
以下のようなケースではどうなればいいのでしょう。

  A       B   C  
1 表タイトル1
2 表タイトル2
3 整理番号   項目1 項目2 
4 21       --  -- 
5 22       --  -- 
6 22       --  --
7 22       --  --
8 23       --  --
9 23       --  --
10 23       --  --
11 23       --  --
12 25       --  --

行挿入や行削除は 下から見ていったほうが楽な気がします。

【55852】Re:特定の行を、任意の複数箇所に挿入・...
発言  taro  - 08/5/21(水) 13:46 -

引用なし
パスワード
   ▼kanabun さん:
ありがとうございます。
下記のような形です。

  A       B   C  
1 表タイトル1
2 表タイトル2
3 整理番号   項目1 項目2 
4 21       --  -- 
5 表タイトル1
6 表タイトル2
7 22       --  -- 
8 22       --  --
9 22       --  --
10 表タイトル1
11 表タイトル2
12 23       --  --
13 23       --  --
14 23       --  --
15 23       --  --
16 表タイトル1
17 表タイトル2
18 25       --  --

【55853】Re:特定の行を、任意の複数箇所に挿入・...
発言  taro  - 08/5/21(水) 13:47 -

引用なし
パスワード
   ▼テト さん:

ありがとうございます。
これから試してみます。

【55855】Re:特定の行を、任意の複数箇所に挿入・...
発言  テト  - 08/5/21(水) 13:56 -

引用なし
パスワード
   失礼しました。
上記で載せたコードでは、不具合があったので訂正です。
これで出来ると思うんだけど…。

――――――――――――――――――――――――――――――
Dim iRow As Long

Application.ScreenUpdating = False
iRow = 5

Do
  With Range("A" & iRow)
    If Not .Value = .Offset(-1).Value Then
      Range("A1:A2").EntireRow.Copy
      .EntireRow.Insert xlDown
      iRow = iRow + 2
    End If
    iRow = iRow + 1

    If .End(xlDown).Row = Rows.Count Then
      Exit Do
    End If
  End With
Loop

Application.ScreenUpdating = True
Application.CutCopyMode = xlCopy
――――――――――――――――――――――――――――――

【55859】Re:特定の行を、任意の複数箇所に挿入・...
発言  kanabun  - 08/5/21(水) 14:11 -

引用なし
パスワード
   ▼taro さん:
> 下記のような形です。

ちがってたらごめんなさい。

下から挿入
 Dim c As Range
 Dim i As Long, LastRow As Long
 
 Set c = Rows("1:2")
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 For i = LastRow To 4 + 1 Step -1
  If Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
    c.Copy
    Rows(i).Insert
  End If
 Next
 Application.CutCopyMode = True

【55860】Re:特定の行を、任意の複数箇所に挿入・...
お礼  taro  - 08/5/21(水) 14:18 -

引用なし
パスワード
   ▼テト さん:

ありがとうございます。
改めてアップしてくださったコードで解決しました。
ご面倒をおかけしました。助かりました。

【55861】Re:特定の行を、任意の複数箇所に挿入・...
お礼  taro  - 08/5/21(水) 14:19 -

引用なし
パスワード
   ▼kanabun さん:

ありがとうございます。
テトさんとは違う方法ですが、同じように私の悩みは解決しました。
勉強になりました。
ご面倒をおかけしました。

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