• ベストアンサー
  • すぐに回答を!

Excel VBAの質問。行のコピーと削除について

Excel VBAでSheet1のD列に「処分」という文字が入力されていたら、その行を Sheet2へコピーし、Sheet1のその行を削除するというマクロを作成したいのですが、 削除をさせる位置が悪いのか件数が合いません。 下の例では、Sheet1のD列には「処分」という文字が入力されている行が3行あります。 Sheet1の1,3,4行目をSheet2へコピーした後にSheet1の1,3,4行目を削除して 行を上に詰めたいのです。 ネットで検索したり、書籍を読みながらここまで作成したのですが、どうしてもうまくいきません。 大変困っております。どうか、間違えている箇所を教えてください。よろしくお願いします。 A B C D E F -|----------------------------------------- 1| 1 03/01 時計 処分 倉庫 特になし 2| 2 03/05 電話 保留  倉庫 連絡済 3| 3 03/10 紙袋 処分 売店  使用済み 4| 4 03/11 電池 処分  倉庫 空白 5| 5 03/12 時計 保留  売店  空白 Private Sub cmdmSyobun_Click() Dim SyobunWord As String Dim gyou As Long Dim word As String Dim LastRow As Long Dim hantei As Integer Dim count As Integer Dim baseB As Workbook Dim baseS As Worksheet SyobunWord = "処分" Set baseB = ThisWorkbook Set baseS = baseB.Worksheets("Sheet1") baseS.Activate With Worksheets("Sheet1") hantei = MsgBox("「処分」データを移動しますか?", vbYesNo) Select Case hantei Case vbYes count = 0 gyou = 2 LastRow = baseS.Cells(Rows.count, 1).End(xlUp).Row Do While Cells(gyou, 4) <> "" word = Cells(gyou, 4) If InStr(word, MoveWord) >= 1 Then count = count + 1 Rows(gyou).Copy Worksheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Offset(1, 0) Rows(gyou).Delete Shift:=xlShiftUp End If gyou = gyou + 1 Loop Case vbNo MsgBox "「処分」データは移動されませんでした。" End Select End With MsgBox MoveWord & "は、" & count & "件でした。" End Sub

共感・応援の気持ちを伝えよう!

  • 回答数1
  • 閲覧数468
  • ありがとう数1

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.1
  • kybo
  • ベストアンサー率53% (349/647)

間違えているところ 最初に SyobunWord = "処分" としているのに、 If InStr(word, MoveWord) >= 1 Then となっている。 If InStr(word, SyobunWord) >= 1 Then とすべき。 あと、コピーしたものを消していって上に詰めていくので、下から検索しないとだめです。 例えば、上からすると1番目で見つかって削除されたら、2番目にあった行が1行目に移動してしまいます。なので、ずれます。 ということで、以下の様になります。 Private Sub cmdmSyobun_Click() Dim SyobunWord As String Dim gyou As Long Dim word As String Dim LastRow As Long Dim hantei As Integer Dim count As Integer Dim baseB As Workbook Dim baseS As Worksheet SyobunWord = "処分" Set baseB = ThisWorkbook Set baseS = baseB.Worksheets("Sheet1") baseS.Activate With Worksheets("Sheet1") hantei = MsgBox("「処分」データを移動しますか?", vbYesNo) Select Case hantei Case vbYes count = 0 gyou = Range("A" & Rows.count).End(xlUp).Row LastRow = baseS.Cells(Rows.count, 1).End(xlUp).Row Do While Cells(gyou, 4) <> "" word = Cells(gyou, 4) If InStr(1, word, SyobunWord) >= 1 Then count = count + 1 Rows(gyou).Copy Worksheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Offset(1, 0) Rows(gyou).Delete Shift:=xlShiftUp End If gyou = gyou - 1 If gyou = 0 Then Exit Do Loop Case vbNo MsgBox "「処分」データは移動されませんでした。" End Select End With MsgBox MoveWord & "は、" & count & "件でした。" End Sub

共感・感謝の気持ちを伝えよう!

質問者からのお礼

早速教えて頂きましてありがとうございました。 ネットで調べたときに、下から検索するというのを見つけ自分なりに考えてコードを書いてみたのですが、どうもうまく動かずでした。 教えていただき、改めてコードを見て、動きを確認し、希望通りの動きをしたのでもう感動モノでした。 本当にありがとうございました。他にも似たようなことをしたい箇所がありますので、このコードを元にまた自分で考えてチャレンジしたいと思いました。本当に助かりました。ありがとうございました。

関連するQ&A

  • Excel VBAで検索結果を新規ブックにコピー

    Excel VBAの質問です。 コンボボックスで選択した文字列とSheet1のC列の文字列が一致したら、 その行を新規ブックのSheet1にコピーしたいのですが、うまくできません。 新規ブックは開くのですが、データはコピーされていません。 既存ブックのSheet2にはコピーできるので、たぶん、新規ブックのSheet1へコピーという 命令がうまくかけていないのだと思います。 書籍やネットで調べてもよく分かりませんでした。 大変困っているので、どなたかご教授ください。よろしくお願いします。 元のSheet1は以下のようにデータが入力されています。 例えば、コンボボックスで「めがね」と選択されたら、1,4,5行目のC列と一致するので それらの行を新規ブックにコピーしたいのです。 A B C D ----------------------------- 1|10 10:00 めがね 保管中 2|11 12:00 衣服  倉庫 3|12 13:00 自転車 保管中 4|13 11:00 めがね 保管中 5|14 13:00 めがね 倉庫 Private Sub Search_Click() Dim SearchWord As String Dim gyou As Long Dim word As String Dim LastRow As Long Dim count As Integer Dim baseBook As Workbook Dim newBook As Workbook Dim baseSheet As Worksheet Dim newSheet As Worksheet SearchWord = cmbsSyutokubutu_search.Text Set baseBook = ThisWorkbook Set baseSheet = baseB.Worksheets("Sheet1") baseSheet.Activate With Worksheets("Sheet1") count = 0 gyou = 4 LastRow = baseSheet.Cells(Rows.count, 5).End(xlUp).Row Set newB = Workbooks.Add Set newS = newBook.Worksheets("Sheet1") Do While Cells(gyou, 3) <> "" word = Cells(gyou, 3) If InStr(word, SearchWord) >= 1 Then Rows(gyou).Copy newBook.Cells(Rows.count, 1).End(xlUp).Offset(1, 0) End If gyou = gyou + 1 Loop End With End Sub

  • エクセル 同じ内容行削除マクロ 2

    シート1、シート2(基準)のB列を比較して同じ内容行を削除したいのですが、「栃木県3」と「#栃木県3」を同じのもと考えて削除されてしまいます。 Sub 削除()   Dim wh1     As Worksheet   Dim wh2     As Worksheet   Dim f      As Range   Dim wR     As Integer   Dim mR     As Long   Dim wStr    As String   '   Set wh1 = Worksheets("Sheet1")   Set wh2 = Worksheets("Sheet2")   wR = 0   With wh1     mR = .Cells(Rows.Count, "A").End(xlUp).Row     For wR = mR To 1 Step -1       wStr = .Cells(wR, "B")       Set f = wh2.Range("B1:B" & wh2.Cells(Rows.Count, "B").End(xlUp).Row).Find(wStr)       If Not f Is Nothing Then         .Rows(wR).Delete       End If     Next   End With End Sub 解決策教えて下さい。

  • ExcelのVBAについての質問です。

    ExcelのVBAについての質問です。 計測機器をつないでsheet1に数値が書き込まれていってる状況です。下記のプログラムを特定の時間内に複数回ループされるように設定したいのですが、そのようなプログラムを加えればいいのでしょうか? Sub Macro1() ' ' Macro1 Macro ' ' Dim iRows As Integer Dim sRows As String ' 最終行の調査: iRows = Worksheets("Sheet1").UsedRange.Rows.Count ' 最終行をシート3にコピー Worksheets("Sheet1").Rows(iRows).Copy Destination:=Worksheets("Sheet3").Range("1:1") ' CH1 の最新データをシート3にコピー Worksheets("Sheet3").Range("B4").Value = Worksheets("Sheet1").Cells(iRows, 3).Value ' CH2 の最新データをシート3にコピー Worksheets("Sheet3").Range("B5").Value = Worksheets("Sheet1").Cells(iRows, 4).Value End Sub

  • エクセルVBAについて

    前回質問させていただきました件の追加機能になります。以前質問させていただきましたマクロが下記のものです。 Sub TESTa() Dim A As Long Dim B As Long Dim C As Long Dim D As Long Dim E As Long Dim F As Long '表の行数を調べる A = Worksheets("sheet1").Range("C65536").End(xlUp).Row - 1 For C = 1 To A For B = 4 To 7 'Sheet1のデータをSheet2に複写する Worksheets("Sheet2").Cells(B - 3 + D, 15) = Worksheets("Sheet1").Cells(C + 1, 1) Worksheets("Sheet2").Cells(B - 3 + D, 6) = Worksheets("Sheet1").Cells(C + 1, B) Worksheets("Sheet2").Cells(B - 3 + D, 14) = Worksheets("Sheet1").Cells(C + 1, 3) Worksheets("Sheet2").Cells(B - 3 + D, 10) = Worksheets("Sheet1").Cells(1, B) Worksheets("Sheet2").Cells(B - 3 + D, 13) = Worksheets("Sheet1").Cells(C + 1, 2) Next D = C * 4 Next 'Sheet2の表の行数を調べる Sheets("Sheet2").Select E = Worksheets("sheet2").Range("F65536").End(xlUp).Row '0欄の確認 For F = E To 1 Step -1 If Worksheets("Sheet2").Cells(F, 6) = 0 Then '0の場合は行を削除する Cells(F, 1).EntireRow.Delete End If Next End Sub カウントするとデータ個数がSheet1で約120件になりSheet2においては、4倍になりますので約480件になります。 そこで Sheet1において12件ごとに、Sheet2,3,4...としたいのです。 Sh1 NO.1~12がSheet2 Sh1 NO.13~24がSheet3 ... 10枚のシートにしたいのですが、このマクロにどのような命令を加えればよろしいでしょうか? お手数ですがよろしくお願いいたします。

  • ExcelのVBAについて質問です。Excelは2003です。

    ExcelのVBAについて質問です。Excelは2003です。 コマンドボタン1で下記のプログラムを実行するようにしています。 Sub Macro1() ' ' Macro1 Macro ' ' Dim iRows As Integer Dim sRows As String Dim i As Integer For i = 1 To 100 Application.Wait Now + TimeValue("00:00:05") ' 最終行の調査: iRows = Worksheets("Sheet1").UsedRange.Rows.Count ' 最終行をシート3にコピー Worksheets("Sheet1").Rows(iRows).Copy Destination:=Worksheets("Sheet4").Range("1:1") ' CH1 の最新データをシート3にコピー Worksheets("Sheet3").Range("B9").Value = Worksheets("Sheet1").Cells(iRows, 3).Value ' CH2 の最新データをシート3にコピー Worksheets("Sheet3").Range("C9").Value = Worksheets("Sheet1").Cells(iRows, 4).Value Next i End Sub これをコマンドボタン2で途中でも強制的に終了するようにしたいのですがコマンドボタン2にはどのようなプログラムを入れればいいでしょうか?

  • Excel2007で最下行のコピーについて

    Excel2007で最下行のコピーについてなんですが、上手くいきません。そこで質問させて頂きます。 sheet3のセルO6、セルP6、セルQ6から下に向かって5000行目までに格子と関数が既に入ってます。 が、しかしコピーをしたい数値は今のところはO、P、Qの6行目にとどまっています。なので最下行はセルOPQの6行目になります。 sheet3のセルOPQの最下行数値をsheet4のセルABCの2行目にコピぺしたいです。 そこで作ってみました。基軸と言いますかsheet1を選択してから標準モジュールに Sub test() Worksheets("sheet3").Select Dim n As Long,t As Long n = Cells(Rows.Count,"O").End(xlUp).Row + 1 t = Cells(Rows.Count,"Q").End(xlUp).Row + 1 Range("O" & n, "Q" & t).Value.Select Selection = Worksheets("sheet4").Range("A2:C2").Value End Sub と書きましたがエラーになります。どの様すればよろしいですか?お願い致します。

  • Excel VBA; 複数のループ処理

    ↓のようなコードがあります。 Dim i As Long, MaxRow1 As Long, MaxRow2 As Long MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To MaxRow1 Worksheets("Sheet1").Cells(i, 1).Value = i . Next i For i = 1 To MaxRow2 Worksheets("Sheet2").Cells(i, 1).Value = i . Next i これらを最大行の多いシートに合わせて、パフォーマンスを良くしたいと思います。 同様の処理をシート1、シート2で実施しているので纏めて記述したいです。 シート1、シート2に対する処理をサブルーチンにする方法しかありませんか? どなたかお願いします。 If MaxRow1 >= MaxRow2 Then For i = 1 To MaxRow1 Else For i = 1 To MaxRow2 End If Worksheets("Sheet1").Cells(i, 1).Value = i Worksheets("Sheet2").Cells(i, 1).Value = i . Next i

  • エクセル 最終行からの連続コピー

    エクセルで最終行から上に連続する10行(最終行含む)をコピーしたいです。 途中、空白行が含まれている場合でも、最終行を特定し、コピーできるようにするには、下記のコードにどう手を加えたらよいでしょうか? どなたかアドバイスをお願いします。 Sub Test()   Dim i As Long   Dim j As Integer   Dim rng As Range   With ActiveSheet     'フィルタ     .Range("A1").CurrentRegion.AutoFilter Field:=1          '行選択     With .AutoFilter.Range       For i = .Cells(.Cells.Count).Row To 2 Step -1         If .Rows(i).Hidden = False Then           If rng Is Nothing Then             Set rng = .Rows(i)           Else             Set rng = Union(rng, .Rows(i))           End If           j = j + 1         End If         If j >= 10 Then Exit For       Next i       'コピー       If Not rng Is Nothing Then         rng.Copy Worksheets("Sheet2").Range("A1")         Beep       Else         MsgBox "該当行は存在しません。", 48       End If     End With   End With   Set rng = Nothing なお、コードはこちらを参考にさせていただきました。 http://okwave.jp/qa3552420.html?ans_count_asc=1

  • EXCEL VBA4行毎に枠で囲みたい

    お世話になります。 添付の様な表1があります。 これを表2のようにA1から順に4行毎に枠で囲みたいのです。 下記のようなコードを見よう見まねで書いてみましたがうまく動きません。 ごなたかご教授いただけませんでしょうか? よろしくお願い致します。 Dim i As Long Dim j As Long Dim lngYCnt As Long Dim intXCnt As Long Dim LastRow As Long ingYCnt = Worksheets("Sheet1").UsedRange.Rows.Count intXCnt = Worksheets("Sheet1").UsedRange.Columns.Count LastRow = Cells(Rows.Count, 1).End(xlUp).Row With Selection For i = 5 To LastRow Range("A" & i & ":F" & j).Select Selection.BorderAround Weight:=xlMedium j = j + 5 i = i + 5 Next End With どなたかご教授いただけませんでしょうか? よろしくお願い致します。 環境 EXCEL2003 WINDOWS XP SP3

  • Excel VBAで検索する

    Excel VBAで、Sheet1に貼り付けたテキスト内から Sheet2に記載した(1列ごとの)キーワードを検索し キーワードが含まれている行をSheet3に貼り付ける処理をしているのですが、始めたばかりなので上手くいきません。 下記がソースです。 Dim moji As String Dim word As String Dim result As Integer For i = 3 To 103 For j = 2 To 21 moji = ThisWorkbook.Worksheets("Sheet1").Cells (i, 1).Value word = ThisWorkbook.Worksheets("Sheet2").Cells (j, 2).Value result = InStr(moji, word) If doResult <> 0 Then For k = 1 To 100 ThisWorkbook.Worksheets("Sheet3").Cells (k, 1).Value= moji Next k End If Next j Next i このソースでは上手くいかないのですが、どこがダメなのか分からないので、解決の糸口がつかめません。 アドバイスなどお願いします。