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

再質問 EXCEL データをコピーして別シートの最初の空白行に貼り付け

再質問 EXCEL データをコピーして別シートの最初の空白行に貼り付けたい QNo.6023986でEXCEL データをコピーして別シートの最初の空白行に貼り付けたいと書き込んだものです。 質問内容は以下の通りです。 Sheet1はA列からR列までを使ったシートで、1行目は各項目があり、2行目からは当月のデータが入力されています。 Sheet2はSheet1の1行目と同じようにA列からR列までが項目になっていて、期中のデータを付け足していきたいと思っています。 マクロの記録でやってみたのですが、前月の最後の行(貼り付ける最初の空白行)の認識の仕方が分からず、Sheet2への貼付がうまくいきません。 どのような方法でやったらいいのか教えて下さい。 ----------------------------------------------------------------------------------- 回答で以下のマクロを教えていただき、テストではうまくいったのですが、 ひとつのブック内でsheet1をsheet2に、sheet3をsheet4に、sheet5をsheet6にと行いたいので、 以下のコードのシート名をそれぞれ書き換えてやってみました。 ところが、1を2にはできたのですが、3を4でやってみたところ、 なんどやっても『400』というエラーが出てしまいます。 シート名の他にも書き換えが必要なのか教えてください。 よろしくお願いします。 Sub Macro1() GYOU1 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row GYOU2 = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets("Sheet1").Select Range(Cells(2, 1), Cells(GYOU1, 18)).Copy Sheets("Sheet2").Select Range("A" & GYOU2).Select ActiveSheet.Paste Application.CutCopyMode = False End Sub

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

  • 回答数25
  • 閲覧数1617
  • ありがとう数28

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

  • ベストアンサー
  • 回答No.25
  • mar00
  • ベストアンサー率36% (158/430)

お詫び こちらから回答させてもらったマクロは どれも動作確認して問題なく動作したものです。 しかしorange1010さんの方では正しく動作しないという事で 原因はなにかと色々考えましたが、こちらで同じ問題がおこらないので どうしてなのかわかりません(私の力量不足です。) もう一度、改めて質問して他の人の知恵を借りた方が解決するのも 早いと思います。 解決出来ないままなのは本当に残念ですが、orange1010さんも 早く解決させたいと思いますので、回答するのを終わりにさせてもらいます。 本当に申し訳ないです。すいません。

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

質問者からのお礼

今までこんなにお付き合いいただいただけでも助かりました。 ありがとうございました。

関連するQ&A

  • VBA 最終行を選んだシートにコピーする。

    VBAど初心者です。どうしても最終行のデータを選んだシートにコピーできません。 LastRow.Selectのところで、止まってしまいます。どのように行を設定していいのかさっぱりわかりません。どなたか、ご指導のほどよろしくお願いします。 Sub copy_last_line() Dim LastRow As Long Sheets("Sheet1").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row LastRow.Select Selection.Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("A1").Select End Sub

  • EXCEL データをコピーして別シートの最初の空白行に貼り付けたい

    EXCEL データをコピーして別シートの最初の空白行に貼り付けたい Sheet1はA列からR列までを使ったシートで、1行目は各項目があり、2行目からは当月のデータが入力されています。 Sheet2はSheet1の1行目と同じようにA列からR列までが項目になっていて、期中のデータを付け足していきたいと思っています。 マクロの記録でやってみたのですが、前月の最後の行(貼り付ける最初の空白行)の認識の仕方が分からず、Sheet2への貼付がうまくいきません。 どのような方法でやったらいいのか教えて下さい。

  • 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

その他の回答 (24)

  • 回答No.24
  • mar00
  • ベストアンサー率36% (158/430)

Sub Macro71() Dim GYOU As Integer Sheets("1-4").Select GYOU = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False Sheets("1-1").Select For INP = 2 To Cells(Rows.Count, 1).End(xlUp).Row Sheets("1-1").Select GYOU = GYOU + 1 For INP2 = 1 To 18 Sheets("1-1").Select DATA = Cells(INP, INP2).Value Sheets("1-4").Select Cells(GYOU, INP2) = DATA Next INP2 Next INP Application.ScreenUpdating = False Sheets("1-4").Select Range("A1").Select End Sub を実行してみて下さい。 1-4にコピーされるまで砂時計になって 少々時間がかかりますが。

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

質問者からのお礼

Sub Macro71() Dim GYOU As Integer Sheets("1-4").Select GYOU = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False Sheets("1-1").Select ここから For INP = 2 To Cells(Rows.Count, 1).End(xlUp).Row Sheets("1-1").Select GYOU = GYOU + 1 For INP2 = 1 To 18 Sheets("1-1").Select DATA = Cells(INP, INP2).Value Sheets("1-4").Select Cells(GYOU, INP2) = DATA Next INP2 Next INP ここへ Application.ScreenUpdating = False Sheets("1-4").Select Range("A1").Select End Sub "ここから""ここへ"と書いたところ ここからここへ飛びます。 また砂時計にもならず貼り付けされませんでした。

  • 回答No.23
  • mar00
  • ベストアンサー率36% (158/430)

15から19を繰り返しているという事は 正しい動作をしているという事です。 1-4にデータがはいると思います。 ステップインではなくて普通にマクロを実行してみて下さい。

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

質問者からのお礼

1 Sub Macro1() 2 Dim GYOU As Integer 3 Dim INP As Long 4 Sheets("1-4").Select 5 GYOU = Cells(Rows.Count, 1).End(xlUp).Row 6 'Application.ScreenUpdating = False 7 Sheets("1-1").Select 8 For INP = 2 To 1000000 9 Sheets("1-1").Select 10 If IsEmpty(Cells(INP, 1)) Then 11 Exit For 12 Else 13 GYOU = GYOU + 1 14 For INP2 = 1 To 18 15 Sheets("1-1").Select 16 DATA = Cells(INP, INP2) 17 Sheets("1-4").Select 18 Cells(GYOU, INP2) = DATA 19 Next INP2 20 End If 21 Next INP 22 'Application.ScreenUpdating = False 23 Sheets("1-4").Select 24 Range("A1").Select 25 End Sub 11から22に飛んで貼り付けされずに終わってしまいました・・・・

  • 回答No.22
  • mar00
  • ベストアンサー率36% (158/430)

もういぢそのままマクロを実行してみて下さい。 シート1-1にシートの保護など通常の書式設定以外に 何か設定してますか?。

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

質問者からのお礼

設定してないです。 ’をはずして実行してみたところ、19まで行って、 15に戻るということを繰り返しているようです。

  • 回答No.21
  • mar00
  • ベストアンサー率36% (158/430)

11から22に飛ぶということなので 6 Application.ScreenUpdating = Falsesと 22 Application.ScreenUpdating = Falseの 頭に ' を追加(緑色に変わる) シート1-1のセルA2に入力されたデータがあるかを確認して下さい。 シート1-1のセルA2に入力されたデータがある場合 シート1-1を開く ステップインを開始 マクロではなくてExcelの動きを確認しながら 5が黄色くなった時、シート1-4が開いているか 6が黄色くなった時、GYOUは2になっているか 8が黄色くなった時、シート1-1が開いているか 以上を確認して下さい。 シート1-1のセルA2に入力されたデータがない場合 8の1000000を Cells(Rows.Count, 1).End(xlUp).Rowになおす 10から12、20を削除 してから実行してみて下さい。

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

質問者からのお礼

ご指導通り、以下のように変えました。 1 Sub Macro1() 2 Dim GYOU As Integer 3 Dim INP As Long 4 Sheets("1-4").Select 5 GYOU = Cells(Rows.Count, 1).End(xlUp).Row 6 'Application.ScreenUpdating = False 7 Sheets("1-1").Select 8 For INP = 2 To 1000000 9 Sheets("1-1").Select 10 If IsEmpty(Cells(INP, 1)) Then 11 Exit For 12 Else 13 GYOU = GYOU + 1 14 For INP2 = 1 To 18 15 Sheets("1-1").Select 16 DATA = Cells(INP, INP2) 17 Sheets("1-4").Select 18 Cells(GYOU, INP2) = DATA 19 Next INP2 20 End If 21 Next INP 22 'Application.ScreenUpdating = False 23 Sheets("1-4").Select 24 Range("A1").Select 25 End Sub >シート1-1のセルA2に入力されたデータがあるかを確認して下さい あります。1-1のA2にはいつもデータが入った状態です。 >5が黄色くなった時、シート1-4が開いているか 開いています。 >6が黄色くなった時、GYOUは2になっているか  5から7に飛ぶので確認できませんでした。 >8が黄色くなった時、シート1-1が開いているか  開いています。

  • 回答No.20
  • mar00
  • ベストアンサー率36% (158/430)

すいません。 回答を送ったと思っていたのですが 送信されていませんでした。 行数の増減は問題ないです。 Sub Macro1() Dim GYOU As Integer Dim INP As Long Sheets("1-4").Select GYOU = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False Sheets("1-1").Select For INP = 2 To 1000000 Sheets("1-1").Select If IsEmpty(Cells(INP, 1)) Then Exit For Else GYOU = GYOU + 1 For INP2 = 1 To 18 Sheets("1-1").Select DATA = Cells(INP, INP2) Sheets("1-4").Select Cells(GYOU, INP2) = DATA Next INP2 End If Next INP Application.ScreenUpdating = False Sheets("1-4").Select Range("A1").Select End Sub 一度試してみてください。 今回もダメでしたらNext INPのところにブレークポイントを 設定して、中断したらINPの数値を確認して下さい。 最初は2です。 確認したら継続ボタンを押してまたINPを確認 この作業を数回行ってください。 下から3行目に飛んで終了してしまったら最後に確認した INPの数値を教えて下さい。

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

質問者からのお礼

1  Sub Macro1() 2  Dim GYOU As Integer 3 Dim INP As Long 4 Sheets("1-4").Select 5 GYOU = Cells(Rows.Count, 1).End(xlUp).Row 6 Application.ScreenUpdating = False 7 Sheets("1-1").Select 8 For INP = 2 To 1000000 9 Sheets("1-1").Select 10 If IsEmpty(Cells(INP, 1)) Then 11 Exit For 12 Else 13 GYOU = GYOU + 1 14 For INP2 = 1 To 18 15 Sheets("1-1").Select 16 DATA = Cells(INP, INP2) 17 Sheets("1-4").Select 18 Cells(GYOU, INP2) = DATA 19 Next INP2 20 End If 21 Next INP 22 Application.ScreenUpdating = False 23 Sheets("1-4").Select 24 Range("A1").Select 25 End Sub ありがとうございます。お返事が遅くなって申し訳ありません。 まず、最初に教えてください。 左側に番号を振りましたが、 (1)21にブレークポイントでいいですか? (2)ステップインを開始すると1から4に飛びますがいいですか? (3)11から22に飛びますがいいですか? (4)INPの値というのは8以降の10/16/21のことでしょうか? よろしくお願いします。

  • 回答No.19
  • mar00
  • ベストアンサー率36% (158/430)

念のためですが、一番最初のマクロです。 Sheet1、Sheet2のやつです。 もう一度動かしてみてください。 Sub Macro1() GYOU1 = Sheets("1-1").Cells(Rows.Count, 1).End(xlUp).Row GYOU2 = Sheets("1-4").Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets("1-1").Select Range(Cells(2, 1), Cells(GYOU1, 18)).Copy Sheets("1-4").Select Range("A" & GYOU2).Select ActiveSheet.Paste Application.CutCopyMode = False End Sub これが正常に動かないということはSheet1、Sheet2の時と 1-1、1-4のどこかが違うのではないかと思います。 Sheet1と1-1だとは思うのですが。 それとANo.18のマクロですが EXIT FORから 下から3行目に飛ぶということですが 1-1のA列に空白セルが出てきたら飛ぶようになっているのですが A列は1行目が項目で2行目から最後の行までデータが入力されているのでは ないのでしょうか?

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

質問者からのお礼

本当に申し訳ありません。 混乱してしまっています。 最初から確認してみたところ、最初のファイルと今のファイルでは行数が違う事に気づきました。 本当にすみません・・・ マクロの記録を取ってしまい行数が18ではなく15になっていたのです。 15に変えてみたのですが、出来なかったということは他にもいじる所があるのでしょうか。 以下、現在使用しているファイルです。 1-1(月1でやる作業です) A1~O1まで項目 A2~O2よりデータが入っています。 Q2~R28まではA2~O2のデータをカウントする為の数式等が入っています。 1-4(1-1のデータを一年分とり、ピボットするために継ぎ足していくシートです) A1~O1まで項目(1-1)と同じ項目が入っています。 これと同じ作業を他に2種やります。(項目の数は違います) 私が知識がなさ過ぎる為に、こんなことになってしまって本当に申し訳ありませんでした。 もう一度お力添えいただけないでしょうか?

  • 回答No.18
  • mar00
  • ベストアンサー率36% (158/430)

Sub Macro5() Dim GYOU As Integer Dim INP As Long Sheets("1-4").Select GYOU = Cells(Rows.Count, 1).End(xlUp).Row 'Application.ScreenUpdating = False Sheets("1-1").Select For INP = 2 To 1000000 Sheets("1-1").Select If IsEmpty(Cells(INP, 1)) Then Exit For Else GYOU = GYOU + 1 Sheets("1-1").Select Range(Cells(INP, 1), Cells(INP, 18)).Copy Sheets("1-4").Select Range("A" & GYOU).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False End If Next INP 'Application.ScreenUpdating = False Sheets("1-4").Select Range("A1").Select End Sub シート名の1-1、1-4は半角でテンキーから入力しています。

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

質問者からのお礼

ペーストされませんでした… Exit Forから下から3行目のSheets("1-4").Selectに飛ぶんですが、 それは問題ではないですか?

  • 回答No.17
  • mar00
  • ベストアンサー率36% (158/430)

orange1010さんの返事を見ましたが マクロは正しく動作しているようです。 ただペーストされずに終了した所を除けばですが。 ActiveSheet.Pastek部分を Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False に変えてみてください。 だめだった場合、 こっちも試して見て下さい。 Sub Macro5() Dim WS1 As String Dim WS2 As String Dim GYOU As Long WS1 = InputBox("元データを入力して下さい。") WS2 = InputBox("コピー先を入力して下さい。") Sheets(WS2).Select GYOU = Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False Sheets(WS1).Select For INP1 = 2 To 1000000 Sheets(WS1).Select If IsEmpty(Cells(INP1, 1)) Then Exit For Else GYOU = GYOU + 1 For INP2 = 1 To 18 Sheets(WS2).Cells(GYOU, INP2) = Sheets(WS1).Cells(INP1, INP2) Next INP2 End If Next INP1 Application.ScreenUpdating = False Sheets(WS2).Select Range("A1").Select End Sub

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

質問者からのお礼

どちらも試してみましたが、 ペーストされませんでした…。

  • 回答No.16
  • mar00
  • ベストアンサー率36% (158/430)

Sub Macro1() Dim WS1 As String Dim WS2 As String Dim GYOU1 As Long Dim GYOU2 As Long WS1 = InputBox("元データを入力して下さい。") GYOU1 = Sheets(WS1).Cells(Rows.Count, 1).End(xlUp).Row WS2 = InputBox("コピー先を入力して下さい。") (1) Sheets(WS1).Select (2) Range(Cells(2, 1), Cells(GYOU1, 18)).Copy (3) Sheets(WS2).Select (4) GYOU2 = Sheets(WS2).Cells(Rows.Count, 1).End(xlUp).Row + 1 (5) Cells(GYOU2, 1).Select (6) ActiveSheet.Paste Application.CutCopyMode = False Range("A1").Select End Sub (1)の行が黄色くなった時、GYOU1を(1-1のデータの最終行になるはず) (3)の行が黄色くなった時、1-1が選択されているかを (4)の行が黄色くなった時、1-1のデータ範囲が選択されているかを (5)の行が黄色くなった時、1-4が選択されているかを (6)の行が黄色くなった時、GYOU2を のように確認したい対象がある次の行が黄色くなった時に どういう値になっているかを確認してほしいのです。 最初の方は黄色くなっている時に確認してもEmpty値になります。 通り過ぎて初めて変数が設定されるためです。

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

質問者からのお礼

そういうことだったんですか…申し訳ありませんでした。 (1)  Sub Macro1() (2)  Dim WS1 As String (3)  Dim WS2 As String (4)  Dim GYOU1 As Long (5)  Dim GYOU2 As Long (6)  WS1 = InputBox("元データを入力して下さい。") (7)  GYOU1 = Sheets(WS1).Cells(Rows.Count, 1).End(xlUp).Row (8)  WS2 = InputBox("コピー先を入力して下さい。") (1) (9)  Sheets(WS1).Select (2) (10)  Range(Cells(2, 1), Cells(GYOU1, 18)).Copy (3) (11)  Sheets(WS2).Select (4) (12)  GYOU2 = Sheets(WS2).Cells(Rows.Count, 1).End(xlUp).Row + 1 (5) (13)  Cells(GYOU2, 1).Select (6) (14)  ActiveSheet.Paste (15)  Application.CutCopyMode = False (16)  Range("A1").Select (17)  End Sub 以下、やってみたご報告です。 (1)の行が黄色くなった時、GYOU1を(1-1のデータの最終行になるはず)  >左の数字(7)のGYOU1の所 → GYOU1=301となっていますので合ってます。 (3)の行が黄色くなった時、1-1が選択されているかを  >左の数字(9)の(WS1)の所 → WS=”1-1”となっています。 (4)の行が黄色くなった時、1-1のデータ範囲が選択されているかを  >左の数字(10)の(GYOU1,の所 → GYOU=301 (5)の行が黄色くなった時、1-4が選択されているかを  >左の数字(11)の(WS2)の所 → WS=”1-4” (6)の行が黄色くなった時、GYOU2を  >(12)のGYOU2の所 → GYOU2=2 このようになっています。 ただペーストされずに終了してしまいました。 よろしくお願いします。

  • 回答No.15
  • mar00
  • ベストアンサー率36% (158/430)

Sub Macro1() Dim WS1 As String Dim WS2 As String Dim GYOU1 As Long Dim GYOU2 As Long WS1 = InputBox("元データを入力して下さい。") GYOU1 = Sheets(WS1).Cells(Rows.Count, 1).End(xlUp).Row WS2 = InputBox("コピー先を入力して下さい。") (1) Sheets(WS1).Select (2) Range(Cells(2, 1), Cells(GYOU1, 18)).Copy (3) Sheets(WS2).Select (4) GYOU2 = Sheets(WS2).Cells(Rows.Count, 1).End(xlUp).Row + 1 (5) Cells(GYOU2, 1).Select (6) ActiveSheet.Paste Application.CutCopyMode = False Range("A1").Select End Sub (1)の行が黄色くなった時、GYOU1を(1-1のデータの最終行になるはず) (3)の行が黄色くなった時、1-1が選択されているかを (4)の行が黄色くなった時、1-1のデータ範囲が選択されているかを (5)の行が黄色くなった時、1-4が選択されているかを (6)の行が黄色くなった時、GYOU2を のように確認したい対象がある次の行が黄色くなった時に どういう値になっているかを確認してほしいのです。 最初の方は黄色くなっている時に確認してもEmpty値になります。 通り過ぎて初めて変数が設定されるためです。

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

関連するQ&A

  • エクセル VBA 特定文字がある行を別シートに移動

    ソフト excel2003 o列に文字列が入力された表があります。 マクロ実行時下記のようにするには、VBAのコードをどのように記入すればよろしいでしょうか? 赤枠で囲んだボタンをクリックすると シート1のO列に 中 が入力されている行を切り取りし中シートに貼り付け (下の行は上方向にシフト) ※ シート1の内容は日毎に更新されますので、更新後、赤枠で囲んだボタンをクリックするとその時点で 中 が入力されているものは中シートのリストへ追加されるようにしたいのです。 以前ここで教えていただいたものを参考に作成してみたの(以下に記載)ですがうまくいきません。 お助けいただけないでしょうか。 宜しくお願い致します。 Sub ボタン中シート_Click() 'Sheet2の挿入位置(C列は結合セルではなく、必ず何か入っている事) nMax2 = Sheets("中シート").Cells(Rows.Count, 3).End(xlUp).Row + 1 With Sheets("sheet1") nMax1 = .Cells(Rows.Count, 9).End(xlUp).Row For i = nMax1 To 2 Step -2 If .Cells(o, 15) = "中" Then .Range(.Cells(o, 1), .Cells(o + 1, 10)).Copy Sheets("中シート").Cells(nMax2, 1).Insert Shift:=xlDown .Range(.Cells(o, 1), .Cells(o + 1, 10)).Delete Shift:=xlUp End If Next i End With End Sub

  • シート1のC列の最終行をコピーして同じ行に値貼り付けしたい

    シート1のC列の最終行を取得して その行を丸々値貼り付けするマクロを作りたいと思います。 シート3のB18の値をシート1のC列の最終行の1つ下のセルに値貼り付け すると、その行のA、B列に日付が入力される関数が入っています。(下まで) 関数が入ったままだと、うまくいかない時があるので最終行をコピーして値貼り付けしたいのですが、マクロの作り方を教えてください。 シート1の最終行に貼り付け Sheets("Sheet3").Select Range("B18").Select Selection.Copy Sheets("Sheet1").Select Range("C65536").End(xlUp).Offset(1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False End Sub 最終行をコピーして値貼り付け Dim 最終行 As Integer 最終行 = Range("C65536").End(xlUp).Row Range("A6:C" & 最終行).Select Selection.Copy Sheets("Sheet1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False End Sub このマクロだと、A6からC列の最終行まで全てコピーされてしまうので、C列の最終行のAからC列まで1行だけコピーできないでしょうか?

  • 途中に空白行や列があるデータ範囲

    エクセル2003です。 セルA1からセルC50までデータがあり 10行目と20行目は全て空白、 セルC39が空白で セルE55、F57、G55にはデータがある の状態で以下の構文ですと Sub 範囲コピー1() Range("B3").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy End Sub 途中に空白行や列、空白セルがあり さらに離れた所E55、F57、G55に データが有るのにもかかわらず セルB3からセルG57までを選択してクリップボードにコピー してくれます。 ですが問題がありまして 上記のシートにて A45&#65374;F50を選択してDeleteをし、 さらにセルのF55、G55もDeleteして データ範囲を セルA1&#65374;E44とセルE55のみにしてからから 上記構文を実行すると セルB3からセルE55を選択してクリップボードにコピー してほしいのに、 データ削除前と同様の セルB3からセルG57を選択してクリップボードにコピー されてしまいます。 これはエクセルの手操作 Ctrl+Shift+End でも同じようになりますので当然の結果(※1)と思っています。 (※1→なにか別な方法はありますか?) 上記の使用方法はあまりないのですが 構文を使う時点での最大行数や最大列数は常に不明で 途中空白が有る場合無い場合、 上記のようにシート上でデータ操作をした直後であっても データ削除部分は加味しデータのある範囲だけの取得の対応 が可能な構文を1種類で作成したいのですが どういう方法があるでしょうか? ちなみに Sub 範囲コピー2() Range("B3").Select Range(Cells(Rows.Count, 1).End(xlUp).Row).Select Range(Cells(1, Columns.Count).End(xlToLeft).Column).Select Selection.Copy End Sub これですと 実行時エラー1004 Rangeメソッドは失敗しましたGlobalオブジェクト となります。 ヘルプをクリックしても何も表示されません。 WEB検索するとこのエラーの質問は結構多いのですが 事例が相違する為よく理解できません。 もしかしてRangeなのに 取得できる値が一つの番号でセルを指定できないからでしょうか? エラーになる構文だと最初のRangeは行番号、次のRangeは列番号、 ですので。 で、 Sub 範囲コピー3() Dim 最終行 Dim 最終列 Range("B3").Select 最終行 = Cells(Rows.Count, 1).End(xlUp).Row 最終列 = Cells(1, Columns.Count).End(xlToLeft).Column Cells(最終行, 最終列).Select Selection.Copy End Sub これならエラーにはなりませんが 事例だとセルC50だけが単独選択されて範囲として 取得をしてくれません。 また 1, Columns.Count ですので最終列の列番号の取得が1行目の最終列から左に検索し データのある所の列番号を返すので 3→C列 となってしまい D,E,F列を見つけてくれません。 かといって 55, Columns.Count では データが55行まで無い場合には対応が出来ませんのでこれも駄目です。 途中に空白が無い場合や離れたセルが無い場合でも使いたいので UsedRangeは使用したくない(よくわかってない事もあって)です。 よろしくお願いします。

  • Excelマクロ 複数条件一致データの抽出方法

    お世話になります。 2個の条件に一致するものを別シートに抽出したいのですが、お知恵を貸してください。 Excelシートで下記のような表があります。 これをL列(品名)かつS列(品質)の条件に一致するデータで新しいシートを作成したいのですが、 その際に新しいシート名は"AA1"のようにしたいのです。 条件がC列(品名)だけであれば下記で動いたのですが…。 (データ) A列 入荷日 I列  品目コード L列 品名 S列 品質 V列 在庫 A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V 1/1・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・20 2/2・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・10 2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10 2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10 2/3・・・・01・・・・・・・BB・・・・・・・・1・・・・・・・・・10 ※以下、最大100品目の行数10000程です。  ↓↓ (実行後希望) シート名 AA1 A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V 1/1・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・20 2/2・・・・01・・・・・・・AA・・・・・・・・1・・・・・・・・・10 シート名 AA2 A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V 2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10 2/3・・・・01・・・・・・・AA・・・・・・・・2・・・・・・・・・10 シート名 BB1 A・・・・・・I・・・・・・・・・L・・・・・・・・・S・・・・・・・・・V 2/3・・・・01・・・・・・・BB・・・・・・・・1・・・・・・・・・10 Sub Sheet抽出() Dim i As Long, Lstrow As Long, myName As String Dim MySht As Worksheet, myFlg As Boolean Application.ScreenUpdating = False With Sheets("sheet1") '準備 For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row myName = .Cells(i, 9) 'シートの存在確認 For Each MySht In Worksheets If MySht.Name = myName Then myFlg = True '既にシート在り!! Sheets(myName).Range("a1") _ .CurrentRegion.Offset(1).ClearContents Exit For End If Next '新規シートの追加 If myFlg = False Then Worksheets.Add.Name = myName End If With Sheets(myName) .Range("A1") = "入荷日" .Range("I1") = "品名コード" .Range("L1") = "品名" .Range("S1") = "品質" .Range("V1") = "在庫" End With myFlg = False Next 'データの転記 For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row myName = .Cells(i, 9).Value .Range("A" & i & ":V" & i).Copy _ Sheets(myName).Cells(Rows.Count, 1).End(xlUp).Offset(1) With Sheets(myName) .Activate Lstrow = .Cells(Rows.Count, 1).End(xlUp).Row .Cells(Rows.Count, 1).End(xlUp).Offset(1, 21) = "" .Cells(Rows.Count, 1).End(xlUp).Offset(1, 21) = _ "=SUM(v2:V" & Lstrow & ")" End With Next End With Sheets("Sheet1").Activate Application.ScreenUpdating = True End Sub 実行後希望のように抽出するには、どうすれば良いのでしょうか? よろしくお願いいたします。

  • 別シートに空白セルを詰めデータを自動コピー

    excel2013で、【sheet1】の列にあ&#65374;わ行まであり、行にそれぞれ氏名を入れています。 グループ1とグループ2にページを上下に分けていて、それぞれ合計50名です。 行は各20行まで用意していますが、行によっては空白セルもあります。 この【sheet1】のデータを【sheet2】の1&#65374;100番まで番号を振った隣のB列に空白セルを詰めながら氏名データを並べたいのですが、マクロで出来るでしょうか? ちなみに空白セルを詰めるマクロは下記コードで確認しています。 Sub Macro() Selection.SpecialCells(xlCellTypeBlanks).Select Selection.Delete Shift:=xlUp End Sub シート間のデータ移動の方法も分かるのですが、2つをどう繋ぎ合わせればいいか分かりません。 簡単ですが、sheet1の参考画像も添付していますので、アドバイス宜しくお願いします。

  • セルに背景色がある行を別シートにコピー

    ある一覧表があり、その中のC列のセルにある条件を満たしていれば背景色をつけています。 この色付セルがある行全体を別のシートに順次コピーして一覧表を作成させるマクロを以下のように作ってみました。 h = 6 For i = 7 To 最終行 If Worksheets("一覧表").Cells(i, "C").Interior.ColorIndex = 背景色番号 Then Sheets(1).Select Rows(i).Copy Sheets(2).Select h = h + 1 Rows(h).Select ActiveSheet.Paste End If Next データが少ないときはこれで問題がなかったのですが、件数が増えてきますと処理時間がかなり掛かります。4000件のデータで30分経っても終わりませんでした。 もっと処理時間が短くなるスマートな方法はありませんでしょうか?

  • エクセルVBA データの転記に関して質問です

    在庫管理の為に以下の通りに作成をしています。 (1)シート1からシート2へデータを転記したい。 (2)シート1からシート2へデータを転記した時シート2にはデータが蓄積されていきます (3)シート1のコピー範囲には空白のセルが含まれています。 (4)シート1の空欄の一部は数式による空白があります。 シート1 C8入庫年月日 C9伝票番号 C10品名 C11品番 C12単位 C13数量 C14単価 C15金額 C16入荷先 C17備考 シート2 C4入庫年月日 C5伝票番号 C6品名 C7品番 C8単位 C9入庫数量 C10単価 C11金額 C12入荷先 *C17は転記しません。 以下のとおりに記述しました。 Dim ab As Long Dim cd As Long Range("C9:k18").Copy Sheets("1").Select Cells(Rows.Count, 3).End(xlUp).Offset(1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=True, Transpose:=False ab = Range("H" & Rows.Count).End(xlUp).Row For cd = ab To ab + 10 Step 1 If ActiveSheet.Cells(cd, 8) = "" Then Rows(cd).Delete shift:=xlUp End If Next cd Sheets("2").Select Application.CutCopyMode = False Range("e6").Select End Sub この記述で実行すると、1度目の転記はうまくいくのですが2回目の転記をしたときに空白行が入り、空白行の下に2回目の転記が行われてしまいます。 どうしたら空白行を無視して2回目の転記がうまくいくでしょうか? VBA初心者です。よろしくお願いします。

  • Excel VBA 条件を満たすデータのコピーと計算結果の表示

    Excel2003を使用しています。 Sheet1のある選択範囲に対して(都度、手動で選択します) D列-E列が0でなかったら、その行のデータをSheet2のアクティブセル以下にコピーするという処理を下記のマクロでしています。 下記のマクロにコードを追加することによって、条件を満たすデータをコピーする際、D列-E列の計算結果をSheet2のD列に表示させることは可能でしょうか? 例えば、Sheet1のD5セルに100、E5セルに50と数値が入力されていた場合、Sheet2のD7セルに50と計算結果を表示させたいですのですが…。 (貼り付け先の行は、アクティブセルの行です) よろしくお願いします。 -------------------------------------------------- Sub Macro1()  Sheets("Sheet1").Activate '選択範囲のサイズ取得   With Selection    i = .Cells(1).Row    j = .Cells(1).Column    k = .Cells(.Count).Row    l = .Cells(.Count).Column   End With  Sheets("Sheet2").Activate   ActR = ActiveCell.Row   ActC = ActiveCell.Column  With Sheets("Sheet1")   For m = i To k    If .Cells(m, 4) - .Cells(m, 5) <> 0 Then     .Range(.Cells(m, j), .Cells(m, l)).Copy     Sheets("Sheet2").Cells(ActR, ActC).PasteSpecial Paste:=xlPasteAllExceptBorders     ActR = ActR + 1     Application.CutCopyMode = False    End If   Next  End With End Sub

  • エクセルVBAでデータ最終行取得方法

    エクセルVBAでデータ最終行取得方法で良い方法を教えてください。 データの行数、列数は不定。 最多のデータ行の列も不定。 この条件で、データ最終行を取得するにはどうすればよいでしょうか? lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row では、A列の最終行に限定されます。 lastrow = ActiveSheet.Cells(1, "A").SpecialCells(xlLastCell).Row では、列の限定はありませんが、一旦データ入力後、削除した部分まで入ってしまいます。 lastrow = ActiveSheet.UsedRange.Rows.Count では、データ入力後、削除した部分まで入ってしまい、かつ、1行目など上部が空白の場合、不正確になります。

  • Excelで最終行の空白を削除にする

    ExcelのVBAでつまづいています。 以下のようにコードを書きました。 Sub Auto_Close() Worksheets("Sheet1").Select 'シート1を開く If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData End If 'フィルタをすべてチェックする Filename = Format(Now(), "yyyy-mm-dd-hh-mm-ss") ThisWorkbook.SaveAs Filename:="\\●●●●\●●●●\●●●●\●●●●\●●●●\" & Filename & ".xlsm" 'Excelデータをバックアップ ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select '一番左下の空白セルに移動 ActiveWorkbook.Save '開いているセルを上書き保存 End Sub 次に開いたときにはA列最終行の空白がアクティブになっているはずなのですが、うまくいきません。 バックアップのコードを削除するとうまくいくのですが、なぜそうなるのか意味がわかりません。 どこがおかしいですか?