A列にチェックが入っている行をコピーして、A5の列へ挿入

投稿者 : ワケワカメ     投稿日時 : 2022/06/22(Wed) 10:28:07     OS : Windows 10     EXCEL : Excel 2013

---

こんにちは。
少し困っておりまして、どなたか知識を貸していただけませんでしょうか。

A列からN列までデータが入っております。
A列にチェックが入っている行（A列からN列まで）をコピーして、同シートのA5(ここは固定)に行挿入して転記したいです。面倒なことに、チェックが入っている行は連続しておらず、飛び飛びです。

例えば、この行と、この行と、この行の計3行を、A5から下へ3行挿入して転記したいです。


VBAのサイトを見て、自分なりに変えてみて、コピーした行を別シート(Sheet1からSheet2)へ挿入と転記、ならできました。ですが、同一シート名(Sheet1とSheet1)にすると、行数挿入は正しくできますが、転記内容が一番上のチェックが入った行の内容が同一で転記されるだけです。別シートならうまくいくのに、なぜだろう、と止まってしましました。

どなたか分かる方は、ご教示いただけませんでしょうか。
宜しくお願い致します。

Sub チェックが付いた行をコピーして行挿入して転記()

Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Dim LastRow As Long
Dim i As Long
Dim J As Long
Dim SearchWord As String

    Set Sht1 = Sheets("Sheet1")
    Set Sht2 = Sheets("Sheet2")

    '検索キーワード環境依存文字のチェックマーク
    SearchWord = ChrW(&H2713)

    Sht1.Select
    J = 5

    '最終行取得
    LastRow = Sht1.Cells(Rows.Count, 1).End(xlUp).Row

    For i = 5 To LastRow

        '特定キーワードを含む場合
        If InStr(Cells(i, 1), SearchWord) > 0 Then
        
             '該当データをコピー
              Sht1.Range(Cells(i, 1), Cells(i, 16)).Copy
              '該当データを行挿入して転記
              Sht2.Cells(J, 1).Insert Shift:=xlDown
              J = J + 1
              '選択解除
              Application.CutCopyMode = False
    End If
    Next i
End Sub

投稿者 : ワケワカメ     投稿日時 : 2022/06/22(Wed) 10:29:53

---

ごめんなさい。
タイトルが間違っておりました。

A列にチェックが入っている行をコピーして、A5位置へ挿入

でした。
わかりにくくなってすみません。

投稿者 : てらてら     投稿日時 : 2022/06/22(Wed) 11:28:49

---

こんにちは。

行の削除とか、挿入の時は通常のループが使えません。
検索すべき行が増えていくのですから、ヒットした行をまた検索してしまうのです。
Sheet2なら大丈夫なのは、ただ書き込んでいるだけだからです。

ちなみに行の削除は、逆ループさせないとダメなのは定番の考え方です。

Whileを使うのと、i = i + 1を２つ配置するのがミソです。
参考にしてください。

Sub チェックが付いた行をコピーして行挿入して転記()

Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Dim LastRow As Long
Dim i As Long
Dim J As Long
Dim SearchWord As String

    Set Sht1 = Sheets("Sheet1")
    'Set Sht2 = Sheets("Sheet2")

    '検索キーワード環境依存文字のチェックマーク
    SearchWord = ChrW(&H2713)
    
    Sht1.Select
    J = 5

    '最終行取得
    LastRow = Sht1.Cells(Rows.Count, 1).End(xlUp).Row
    i = 5
    Do While Cells(i, 1) <> ""
        '特定キーワードを含む場合
        If InStr(Cells(i, 1), SearchWord) > 0 Then
        
             '該当データをコピー
              Sht1.Range(Cells(i, 1), Cells(i, 16)).Copy
              '該当データを行挿入して転記
              'Sht2.Cells(J, 1).Insert Shift:=xlDown
              Sht1.Cells(J, 1).Insert Shift:=xlDown
              J = J + 1
              i = i + 1
              '選択解除
              Application.CutCopyMode = False
              
        End If
    
        i = i + 1
        If i > 30 Then Exit Sub　’無限ループ回避のおまじない。
    Loop
    MsgBox i
    

End Sub

投稿者 : 収録     投稿日時 : 2022/06/22(Wed) 11:50:46

---

チェックが入っているというのがどんなものか解りませんが、
オートフィルタ使えば良いと思っています。
こっちの方が楽だし、手動だけでも済みそうだし。

投稿者 : ワケワカメ     投稿日時 : 2022/06/22(Wed) 12:58:06

---

てらてら様

お忙しい中お知恵を貸して頂きありがとうございますm(__)m
ご教示いただいた記述で、Sheet1とSheet2を分けずに、同じシートにした場合、
うまく挙動せず、
メッセージボックスで

5

と表示されていまいました。
MsgBox i
の兼ね合いでしょうか？？

やはり、同一ページにｺﾋﾟｰした行を挿入して転記は難しいでしょうかm(__)m

投稿者 : ワケワカメ     投稿日時 : 2022/06/22(Wed) 12:58:23

---

てらてら様

お忙しい中お知恵を貸して頂きありがとうございますm(__)m
ご教示いただいた記述で、Sheet1とSheet2を分けずに、同じシートにした場合、
うまく挙動せず、
メッセージボックスで

5

と表示されていまいました。
MsgBox i
の兼ね合いでしょうか？？

やはり、同一ページにｺﾋﾟｰした行を挿入して転記は難しいでしょうかm(__)m

投稿者 : ワケワカメ     投稿日時 : 2022/06/22(Wed) 13:10:25

---

収録様


案を頂きありがとうございます。

チェックが入っているものをオートフィルタして抽出された行をコピーしても良いのですが、
エクセルの特性上、飛び飛びの行のコピーは、右クリックで一発貼付ができなくて困っておりました。
現在は、一行一行ｺﾋﾟｰして貼付しております。

全体用途としては、
過去の発注部品一覧があり、ﾁｪｯｸをした行のみ抽出して、注文書を印刷できる。
という機能です。
チェックをした行のみ印刷するというのは、VBAですでに動いており、完了済です。

お困りごととしては、
その過去の発注部品データをコピーして、発注日のみ変えて新規で発注書を印刷したい時に困っております。
が、毎回同じ部品が要るとも限らず（過去の製品の修繕などで一部の部品のみ必要の時など）
行が飛び飛びになってコピーしたいので、手動で1行1行コピペしているのを、自動でできたらいいなと思っておりました。

投稿者 : てらてら     投稿日時 : 2022/06/22(Wed) 14:36:29

---

こちらでは上手くいってますが、、、

Sheet2を開きながらやると失敗します。
一応、シート指定したものを書いておきます。
最後のメッセージボックスは消し忘れです。

Sub チェックが付いた行をコピーして行挿入して転記()

Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Dim LastRow As Long
Dim i As Long
Dim J As Long
Dim SearchWord As String

    Set Sht1 = Sheets("Sheet1")
    'Set Sht2 = Sheets("Sheet2")

    '検索キーワード環境依存文字のチェックマーク
    SearchWord = ChrW(&H2713)
    
    Sht1.Select
    J = 5

    '最終行取得
    LastRow = Sht1.Cells(Rows.Count, 1).End(xlUp).Row
    i = 5
    Do While Sht1.Cells(i, 1) <> ""
        '特定キーワードを含む場合
        If InStr(Sht1.Cells(i, 1), SearchWord) > 0 Then
        
             '該当データをコピー
              Sht1.Range(Cells(i, 1), Cells(i, 16)).Copy
              '該当データを行挿入して転記
              'Sht2.Cells(J, 1).Insert Shift:=xlDown
              Sht1.Cells(J, 1).Insert Shift:=xlDown
              J = J + 1
              i = i + 1
              '選択解除
              Application.CutCopyMode = False
              
        End If
    
        i = i + 1
        If i > 30 Then Exit Sub
    Loop
    'MsgBox i
    

End Sub

投稿者 : ワケワカメ     投稿日時 : 2022/06/22(Wed) 16:08:37

---

てらてら様

他のVBAは動くのですが、
ご指南頂いた内容をコピペしてもなぜかうんともすんとも言わず、
せっかく教えていただいたので私の方で色々試してみたいと思います。

もう少しお時間ください。
宜しくお願い致します。


■[返信 7] てらてらさん（2022-06-22 14:36:29）の記事
＞ こちらでは上手くいってますが、、、
＞
＞ Sheet2を開きながらやると失敗します。
＞ 一応、シート指定したものを書いておきます。
＞ 最後のメッセージボックスは消し忘れです。
＞
＞ Sub チェックが付いた行をコピーして行挿入して転記()
＞
＞ Dim Sht1 As Worksheet
＞ Dim Sht2 As Worksheet
＞ Dim LastRow As Long
＞ Dim i As Long
＞ Dim J As Long
＞ Dim SearchWord As String
＞
＞ Set Sht1 = Sheets("Sheet1")
＞ 'Set Sht2 = Sheets("Sheet2")
＞
＞ '検索キーワード環境依存文字のチェックマーク
＞ SearchWord = ChrW(&H2713)
＞
＞ Sht1.Select
＞ J = 5
＞
＞ '最終行取得
＞ LastRow = Sht1.Cells(Rows.Count, 1).End(xlUp).Row
＞ i = 5
＞ Do While Sht1.Cells(i, 1) <> ""
＞ '特定キーワードを含む場合
＞ If InStr(Sht1.Cells(i, 1), SearchWord) > 0 Then
＞
＞ '該当データをコピー
＞ Sht1.Range(Cells(i, 1), Cells(i, 16)).Copy
＞ '該当データを行挿入して転記
＞ 'Sht2.Cells(J, 1).Insert Shift:=xlDown
＞ Sht1.Cells(J, 1).Insert Shift:=xlDown
＞ J = J + 1
＞ i = i + 1
＞ '選択解除
＞ Application.CutCopyMode = False
＞
＞ End If
＞
＞ i = i + 1
＞ If i > 30 Then Exit Sub
＞ Loop
＞ 'MsgBox i
＞
＞
＞ End Sub
＞

投稿者 : ピロリ     投稿日時 : 2022/06/22(Wed) 16:24:59

---

■[返信 4] ワケワカメさん（2022-06-22 12:58:06）の記事
＞ メッセージボックスで
＞ 5
＞ と表示されていまいました。
ということは、いきなり Sht1.Cells(5, 1) = ""（空白）でループを抜けているということですね。
Ａ列には空白も混在しているって前提で、てらてらさんもコードも使用させていただきつつ、下記を試してみて下さい。
変更箇所は、★印のコードです。

Sub チェックが付いた行をコピーして行挿入して転記()
    
    Dim Sht1 As Worksheet
    Dim Sht2 As Worksheet
    Dim LastRow As Long
    Dim i As Long
    Dim J As Long
    Dim SearchWord As String
    Dim k As Long                       '★ループカウンタ：k を追加しました。
    
    Set Sht1 = Sheets("Sheet1")
    'Set Sht2 = Sheets("Sheet2")
    
    '検索キーワード環境依存文字のチェックマーク
    SearchWord = ChrW(&H2713)
    
    Sht1.Select
    J = 5
    
    '最終行取得
    LastRow = Sht1.Cells(Rows.Count, 1).End(xlUp).Row
    i = 5
    'Do While Sht1.Cells(i, 1) <> ""    '★Ａ列には空白も混在する前提で Do Whileではなく、
    For k = 5 To LastRow                '★Forループに変更してみます。
        '特定キーワードを含む場合
        If InStr(Sht1.Cells(i, 1), SearchWord) > 0 Then
        
             '該当データをコピー
              Sht1.Range(Cells(i, 1), Cells(i, 16)).Copy
              '該当データを行挿入して転記
              'Sht2.Cells(J, 1).Insert Shift:=xlDown
              Sht1.Cells(J, 1).Insert Shift:=xlDown
              J = J + 1
              i = i + 1
              '選択解除
              Application.CutCopyMode = False
              
        End If
        
        i = i + 1
        'If i > 30 Then Exit Sub        '★これは削除とします。
    'Loop                               '★Do ～ Loopではなく、
    Next k                              '★For ～ Next への変更です。
    
    'MsgBox i
    
End Sub

投稿者 : ワケワカメ     投稿日時 : 2022/06/22(Wed) 17:00:05

---

てらてら様
ピロリ様

できました！！！(TT)
あまりに手詰まりしていたので、できた瞬間の感動がすごくて、
本当に感謝しております。
お忙しい中、コードを一生懸命考えてくださり、ありがとうございましたm(__)m