Excel VBAで行のコピーと削除を行う方法

このQ&Aのポイント
  • Excel VBAでSheet1のD列に「処分」という文字が入力されていたら、その行をSheet2へコピーし、Sheet1のその行を削除するマクロを作成したいです。
  • Sheet1のD列には「処分」という文字が入力されている行が3行あります。Sheet1の1,3,4行目をSheet2へコピーし、Sheet1の1,3,4行目を削除して行を上に詰めたいです。
  • 現在作成しているマクロでは、削除をさせる位置が悪いのか件数が合いません。うまくいかない箇所がわかりません。どうか、間違いを教えてください。
回答を見る
  • ベストアンサー

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

  • suzum
  • お礼率100% (1/1)

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

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

間違えているところ 最初に 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

suzum
質問者

お礼

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

関連する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

  • VBA 任意のシートからコピーを始める。

    教えてください。 全てのシートをコピーして一つのシートにまとめるプログラムシートを作成しました。 1番目のシートからコピーを始める場合は For i = 2 To Worksheets.Count 2番目のシートからコピーを始める場合は For i = 3 To Worksheets.Count とすればよいのですがこれだといちいちモジュールコードを出して数字を変更しなければならず面倒です。 そこでユーザーフォームのコンボボックスに任意の数字を入れてクリックを押せば希望するシートからコピーを始めるプログラムを作成してみましたがうまくいきません。どなたか教えてくださいませんか。 Sub matome() Dim i As Integer Dim lRow As Long, lCol As Long, lRow2 As Long, lRow3 As Long, SNo As Integer '----何番目からコピーを始めるかを決定します With UserForm2 SNo = .ComboBox1.value End With For i = 1 + SNo To Worksheets.Count With Worksheets(i) lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 lCol = .Cells(1, Columns.Count).End(xlToLeft).Column '----シートのデータが2行以上の場合にコピーします If lRow >= 2 Then lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 If lRow2 < Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 Then lRow2 = Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 .Activate .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) End If End With Next i

  • エクセル 同じ内容行削除マクロ 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 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に数値が書き込まれていってる状況です。下記のプログラムを特定の時間内に複数回ループされるように設定したいのですが、そのようなプログラムを加えればいいのでしょうか? 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

  • ExcelのVBAでシート選択・最終行取得がうまくいかない。

    シートA・Bがあり、シートAの変数markが★だったら、シートBへいき、最終行を取得、ということをしたくて以下のようなコードをかきました。 Worksheets("A").Select Last3 = Cells(6).CurrentRegion.Rows.Count Worksheets("B").Select Last1 = Cells(6).CurrentRegion.Rows.Count For w = 1 To Last1 Worksheets("B").Select Mark = Cells(w, 26) If Mark = "★" Then Sheets("A").Select Last3 = Cells(6).CurrentRegion.Rows.Count MsgBox Last3 End If Next ですが、シートAの最終行が表示されます。 どこがちがうのでしょうか?

  • 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にはどのようなプログラムを入れればいいでしょうか?

  • エクセルVBAで非アクティブブックのRow取得

    非アクティブシートの最終行のRowを取得するマクロが xls形式のファイルだと動いていたのですが、xlsm形式に変更後、エラーになってしまいました。 これは仕様の変更によるものなのでしょうか? Activeteせずに対処する方法があれば教えて頂きたいです。 Sub ボタン1_Click() Dim 最終行 As Long 最終行 = Workbooks("1.xls").Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row MsgBox 最終行 End Sub

  • VBA sumifで計算できません

    集計シートに入力シートから抽出した重複しない検索データの合計値を入力シートでSUMIFで書いてみましたが  「オブジェクトはこのプロパティまたはメソッドをサポートしていません。」とエラーになります。 何がいけないのか調べてみましたがVBA初心者でわからず困っています。 教えてください。よろしくお願いします。 Dim 集計データ数 As Long Dim 入力シートデータ数 As Long Dim データ行 As Long 集計データ数 = Cells(Rows.Count, 38).End(xlUp).Row 入力シートデータ数 = Worksheets("入力").Cells(Rows.Count,29).End(xlUp).Row For データ行 = 11 To 集計データ数 Cells(データ行, 11).Value = Application.WorksheetFunction.SumIf(Worksheets("入力").Range(Cells(11, 29), Cells(入力シートデータ数, 29)),Cells(データ行, 2), Worksheets("入力").Range(Cells(11, 21), Cells(データ行, 21))) Next データ行 End Sub

  • 配列 変数の宣言 VBA

    こんばんは。 Sub test() Dim myStr(200) As String For 行 = 0 To Cells(Rows.Count, 1).End(xlUp).Row myStr(行) = Cells(行 + 1, 1) Next MsgBox Join(myStr, "_") End Sub のようなコート゛を作成し、 アクティブシートのA列の最終行までを取得し、一つにまとめたいのですが 「Dim myStr(200) As String」の部分で 最終行を取得することは不可能でしょうか? 今回は200行なので大丈夫なのですが 場合によっては1行~65536行までさまざまです。 なので Dim myStr(Cells(Rows.Count, 1).End(xlUp).Row) As String としたらエラーになりました。 最初から Dim myStr(65536) As String とするべきでしょうか? しかしそうすると myStrの最後がずっと「________」となってしまいます。 どうするのが適切なのかわかりません。 ご教授よろしくお願いします。