VBAで複数のワークシートを選択して範囲をコピーする方法

前へ 次へ
このQ&Aのポイント
  • VBAを使用して、すべてのワークシートを順番に選択して指定した範囲をコピーし、別のシートに貼り付ける方法を教えてください。
  • Set sh = Worksheets(sh.Name)でエラーになります。正しい方法を教えてください。
  • Dim sh3 As Worksheet、Dim sh As Worksheet、Dim en As Longとは何ですか？具体的な使い方を教えてください。
回答を見る
  • ベストアンサー

ＶＢＡ　なんですが

ＶＢＡ　なんですが すべてのワークシートを順番に選択して 指定した範囲をコピーし『まとめ』と言う別のシートに貼り付けたいのですが どうしたらいいのかわかりません。 それらしいのは考えたのですが Set sh = Worksheets(sh.Name)でエラーになります。 頭がいいかた教えてください。 　　Dim sh3 As Worksheet Dim sh As Worksheet Dim en As Long Set sh3 = Worksheets("まとめ") For Each sh In ActiveWorkbook.Worksheets If sh.Name <> "まとめ" Then en = sh.UsedRange.Rows.Count Set sh = Worksheets(sh.Name) sh.Range(Cells(2, 1), Cells(en, 10)).Copy

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

  • ベストアンサー
  • watabe007
  • ベストアンサー率62% (476/760)
回答No.3

>アクティブのシートを範囲を決めてコピーする方法なんですが >それを別のシートに貼り付け そのままコードにすると ActiveSheet.Range("範囲1").Copy Worksheets("別のシート").Range("範囲2") 範囲1、範囲2、別のシート名　は、貴方しか解りませんよ ただ推測すると、このような事をしたいのではと？ 参考に Sub Test() 　　Dim sh3 As Worksheet 　　Dim sh As Worksheet 　　Dim en As Long 　　 　　Set sh3 = Worksheets("まとめ") 　　For Each sh In ActiveWorkbook.Worksheets 　　　　If sh.Name <> "まとめ" Then 　　　　　　en = sh.UsedRange.Rows.Count 　　　　　　sh.Range(sh.Cells(2, 1), sh.Cells(en, 10)).Copy _ 　　　　　　　　sh3.Cells(Rows.Count, "A").End(xlUp).Offset(1) 　　　　End If 　　Next End Sub

nego1322
質問者

お礼

ほんとうにありがとうござます。 完璧な理想の答えです。 watabe007さん　またＶＢＡで分からないことがありましたら 教えてください。 本当に助かりました。

その他の回答 (2)

  • watabe007
  • ベストアンサー率62% (476/760)
回答No.2

>Cellsプロパティにもシート(sh)を参照と言うのはどのようなことですか？ sh.Range(Cells(2, 1), Cells(en, 10)).Copy これだと　shシートのRang(を指していますが sh.Range(Cells Rangeの中のCellsプロパティはシートを指定していないのでアクティブシートを指しています

nego1322
質問者

補足

全てのシートを順番に読んでいき アクティブのシートを範囲を決めてコピーする方法なんですが それを別のシートに貼り付け また次のシートを読むプログラムを教えてください。 For Each sh In ActiveWorkbook.Worksheets 　　If sh.Name <> "まとめ" Then 　　　　en = sh.UsedRange.Rows.Count 　　　　sh.Range(sh.Cells(2, 1), sh.Cells(en, 10)).Copy

  • watabe007
  • ベストアンサー率62% (476/760)
回答No.1

Dim sh3 As Worksheet Dim sh As Worksheet Dim en As Long Set sh3 = Worksheets("まとめ") For Each sh In ActiveWorkbook.Worksheets 　　If sh.Name <> "まとめ" Then 　　　　en = sh.UsedRange.Rows.Count 　　　　sh.Range(sh.Cells(2, 1), sh.Cells(en, 10)).Copy Cellsプロパティにもシート(sh)を参照してやる必要があります。

nego1322
質問者

補足

ありがとうございます。 ＶＢＡが不慣れでして Cellsプロパティにもシート(sh)を参照と言うのはどのようなことですか？ すいません。返事お願いします。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. その他（プログラミング・開発）

関連するQ&A

  • VBA　シート指定とファイル名入力

    部署ごとに分割し、ブックで保存するコードです。 sheet名は「部署」です。 Sub macro1() Dim w As Worksheet Dim n As Long Dim r As Long Dim s As String Dim WSH As Variant Dim myPath As String Set w = ActiveSheet n = Worksheets.Count Application.ScreenUpdating = False On Error GoTo errhandle For r = 5 To w.Range("B65536").End(xlUp).Row s = w.Cells(r, "B") w.Rows(r).Copy Worksheets(s).Range("B65536").End(xlUp).Offset(1, -1) Next r On Error GoTo 0 Set WSH = CreateObject("Wscript.Shell") myPath = ActiveWorkbook.Path & "\1\" For r = Worksheets.Count To n + 1 Step -1 Worksheets(Worksheets.Count).Copy ActiveSheet.Columns.AutoFit ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name ActiveWorkbook.Close False Application.DisplayAlerts = False Worksheets(Worksheets.Count).Delete Application.DisplayAlerts = True Next r w.Select Exit Sub errhandle: Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = s w.Rows(1).Copy Range("A1") w.Rows(2).Copy Range("A2") w.Rows(3).Copy Range("A3") w.Rows(4).Copy Range("A4") Resume Application.ScreenUpdating = True End Sub (1)sheet1にマクロ実行ボタンを配置し、部署seedにマクロ実行命令をする。 (2)sheet1のB2セルにファイル名を入力して、そのファイルに保存する。（例部署ファイル） (1)Dim w As Worksheets("部署")と変更したのですが、エラーが出ました。 (2)myPath = ActiveWorkbook.Path & "\部署ファイル\"　 　↑ これをsheet1のB2セルから指定できるようにしたいです。 宜しくお願いします。

  • エクセル　複数シートを一つのシートにまとめるマクロについて

    エクセル　複数シートを一つのシートにまとめるマクロについて こんにちは　いつもお世話になっています あるサイトから上記の目的のマクロを参考にして試したんですが、所有してるデスクトップPCでは成功するのに、ノートPCでは次のエラーが出ます。 「コンパイルエラー　変数が定義されていません」そして、以下に載せたコードの「k = 1」の部分が青い背景色になります。とりあえず、デスクトップでできるので間に合うのですが、ノートPCでのトラブル理由を今後のために勉強したいのです。理由を教えてください。 エクセル2003　SP3 ノートPCは工人舎のモバイルSA1F0 参考にさせていただいたサイトは「エクセル　複数シートを一つに集約」 http://okwave.jp/qa/q1608016.html?order=DESC&by=datetime コード引用 集約用にSheet3を確保します・ Sheet3以外の全シートを集約します。 Sub test07() Dim sh3 As Worksheet Dim sh As Worksheet Set sh3 = Worksheets("Sheet3") k = 1 For Each sh In ActiveWorkbook.Worksheets If sh.Name <> "Sheet3" Then MsgBox sh.Name sh.UsedRange.Copy sh3.Cells(k, "A").Select sh3.Paste k = k + sh.UsedRange.Rows.Count End If Next End Sub 引用終わり よろしくお願いします

  • エクセル VBA：複数のシートを1つに集約

    以前どこからか以下のようなVBAを見つけ使用していました。 今になり実情に合ったものに改良したいと思い始めたのですが、コピーをとる時のプロパティ UsedRangeが理解できません。 実はデータは少し不完全な場合があり、A列が他の列に比べ不足しております。 解説書などではUsedRangeを使えば、データの一番外枠、つまり全てのデータを含むようにコピーされると理解したのですが、違うのでしょうか。 データはこんな感じです。 A、B XXX、BBB XXX、BBB 、BBB よろしくお願いします。 Sub Sample() Dim sWS As Worksheet 'データシート（コピー元） Dim dWS As Worksheet '集約用シート（コピー先） Set dWS = Worksheets("AllData") '集約用シートの2行目以降を削除 dWS.UsedRange.Offset(1, 0).Clear '各シートの2行目以降のデータを、集約用シートの末尾にコピー For Each sWS In Worksheets If sWS.Name <> dWS.Name Then With sWS.UsedRange 'コピー元シートにデータが1件以上ある場合 If .Rows.Count > 1 Then .Offset(1, 0).Resize(.Rows.Count - 1).Copy _ Destination:=dWS.Cells(Rows.Count, 1). _ End(xlUp).Offset(1, 0) End If End With End If Next sWS End Sub

  • 'Range'メソッドは失敗しました

    ExcelのVBAの質問になりますが、教えてください。 下記を動かすと最後の行で「'Range'メソッドは失敗しました: '_Worksheet' オブジェクト」と出ます どうしても最後の行をセレクトしたいのですが、どうしたらよいでしょうか。 Option Explicit Public WB1 As Workbook Public WB1SH1 As Worksheet Public CSVWB1 As Workbook Public CSVWB1SH1 As Worksheet Dim MaxRow As Integer Private Sub CommandButton1_Click() Set WB1 = ActiveWorkbook Set WB1SH1 = WB1.Worksheets(1) Dim a As String a = WB1SH1.Range("a1) Workbooks.Open "C:\Users\User\Desktop\" & a & ".CSV" Set CSVWB1 = ActiveWorkbook Set CSVWB1SH1 = CSVWB1.Worksheets(1) MaxRow = CSVWB1SH1.Cells(Rows.Count, 1).End(xlUp).Row WB1SH1.Activate WB1SH1.Range(Cells(1, 1), Cells(MaxRow, 3)).Select CSVWB1SH1.Activate CSVWB1SH1.Range(Cells(1, 1), Cells(MaxRow, 3)).Select　　'←ここでエラーがでる End Sub

  • エクセルVBA！（COPY） Win2000，ｏｆｆｃｅ2000

    単純な質問かもしれませんが、 WorkBooks("test"）から 別のWorkBooks("Data").WorkSheets("Sheet1")のデータの数を判定して全てをコピーして、 WorkBooks("test")のWorkSheets("Sheet2")へペーストしたいのですが、うまくいきません ↓のような感じです。 Dim wstest As Worksheet Dim wsData As Worksheet Dim wsNM As String Dim Drow As Long Sub copy() 'DataSheetのSheet名がその都度違うので、取得しました。 wsNM = wsData.Sheets(1).Name Set wsData = Workbooks("Data.xls").Worksheets(wsNM) Set wsTest = Workbooks("Test.xls").WorkSheets("Sheet2") 'データの範囲判定 Drow = wsData.Range("H65536").End(xlUp).Row '/////// ここからが？？？です /////// wsDataのＡ1からＢＡのDrowを範囲を指定して、Copy → wsTestのＡ1に貼り付けたいのですが、どうしたらよいのでしょうか？ コピーしたり、直接書くようにしたりといろいろなコードを書いてみましたがダメでした。 Cellsで範囲をとる方法がわかりません。Rangeなら（A1：BA300）のように取れる範囲もCellsの時はどうしたらよいのでしょうか？（そのまま書けば、Cells（1,1):Cells（Drow,53）みたいな・・・・・) と、悩んでいるより一気にコピーするのもどうかと思いFor～Nextで1行ずつ書いていったらどうかとも考えましたが、うまくいきませんでした。 End Sub ※ Drowは、6000～20000 よろしくお願いします。

  • VBA　同じ場所に保存する

    部署ごとに分割し、ブックで保存するコードです。 保存場所がデスクトップになっています。 これを同じ場所に保存する方法をお知らせください。 よろしくお願いします。 Sub macro1() Dim w As Worksheet Dim n As Long Dim r As Long Dim s As String Dim WSH As Variant Dim myPath As String Set w = ActiveSheet n = Worksheets.Count Application.ScreenUpdating = False On Error GoTo errhandle For r = 2 To w.Range("A65536").End(xlUp).Row s = w.Cells(r, "A") w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1) Next r On Error GoTo 0 Set WSH = CreateObject("Wscript.Shell") myPath = WSH.specialfolders("Desktop") & "\" For r = Worksheets.Count To n + 1 Step -1 Worksheets(Worksheets.Count).Copy ActiveSheet.Columns.AutoFit ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name ActiveWorkbook.Close False Application.DisplayAlerts = False Worksheets(Worksheets.Count).Delete Application.DisplayAlerts = True Next r w.Select Exit Sub errhandle: Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = s w.Rows(1).Copy Range("A1") Resume Application.ScreenUpdating = True End Sub

  • VBA　初心者

    sheet1から、sheet2データを検索して抽出する練習をしているのですがerror"1104"が表示されます、なぜなのか分からないので投稿しました、よろしくお願いします。 sub test() dim sh1 as worksheets dim sh2 as worksheets dim　 i 　as 　integer set sh1 = thisworkbook.worksheets("sheet1!") set sh2 = thisworkbook.worksheets("sheet2!") b = userform1.textbox1 for i = 1 to 10 sh1 .cells(i,2) = b b = b+1 x = sh1.cells(1,2) sh1.cells(i,3).value = worksheetfunction.vlookup(x,sh2.range("a1:d500"),2,false) next i end sub

  • Excel VBA で特定のシートのみ除外

    ＶＢＡで以下のような、ブック内の全シートから特定の文字列が入った行のみを新しくシート作成して一覧化するマクロを組みました。 検索する時に保護解除するなど別の作業もあるため無駄に長くなっております。 Sub 検索() Dim Sh As Worksheet, Rng As Range Dim StrFind As String, Res As String Dim Rw As Long, R As Long Dim N As Integer Const OutShName = "検索結果" StrFind = InputBox("検索する文字列を入力してください。" & " 　　 検索する文字列は正確に。", "検索文字列") If StrFind = vbNullString Then Exit Sub Dim Ws As Worksheet Application.ScreenUpdating = False For Each Ws In Worksheets Ws.Unprotect Password:=908118 Next Application.ScreenUpdating = True Application.ScreenUpdating = False UserForm1.Show vbModeless UserForm1.Repaint For N = 1 To Worksheets.Count If Worksheets(N).Name = OutShName Then Set Sh = Worksheets(N) Sh.Move after:=Worksheets(Worksheets.Count) Sh.Cells.ClearContents Exit For End If Next N If N > Worksheets.Count Then Set Sh = Sheets.Add(after:=Worksheets(Worksheets.Count)) Sh.Name = OutShName End If Worksheets(1).Rows(1).Copy Sh.Rows(1) R = 2 For N = 1 To Worksheets.Count - 1 With Worksheets(N).UsedRange For Rw = 1 To .Rows.Count Set Rng = .Cells(Rw, 1).Resize(, .Columns.Count).Find(StrFind) If Not Rng Is Nothing Then Rng.EntireRow.Copy Sh.Rows(R) R = R + 1 End If Next Rw End With Next N Unload UserForm1 ResultMsg: If R < 3 Then Res = "「" & StrFind & "」 は、見つかりません。" For Each Ws In Worksheets Ws.Protect Password:=908118 Next Sheets("TOP").Select Else Columns("A:A").ColumnWidth = 20 Columns("C:C").ColumnWidth = 13 Rows("1:1").RowHeight = 30 Sheets("12月").Select Rows("1:1").Select Selection.Copy Sheets("検索").Select Range("A1").Select Application.ScreenUpdating = True Res = "「" & StrFind & "」 は、" & R - 2 & " 件 見つかりました。 " & _ String(2, vbLf) & Sh.Name & " に抽出しました。" Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.Font.Bold = False Selection.Font.Bold = True End If MsgBox Res, vbInformation, "検索完了" Set Rng = Nothing End Sub Excel2003を使用してます。 シートは30枚程あり、複雑な計算式等が入っています。 この時、特定のシート（例:"月別データ")のみを除外したいのですが、いまいちわかっておりません。 稚拙な質問かと思いますがご指導していただきたく思います。

  • エクセルVBA【ワークシートのコピー】について

    以下のVBA記述で、とあるエクセルファイルのシートをCSV化しようとしております。記述の場合、すべてのワークシートが対象となっていますが、１０個くらいあるWorkSheetの【sheets(8)】のみを対象としたいのですが、どのようにしたら良いのでしょうか？ お手数ですがご教授下さい。 Sub test() Dim sh As Worksheet Dim fname As String Application.ScreenUpdating = False For Each sh In ActiveWorkbook.Worksheets fname = "C:\temp\" & sh.Name & ".csv" sh.Copy With ActiveWorkbook .SaveAs Filename:=fname, FileFormat:=xlCSV .Close savechanges:=False End With Next sh Application.ScreenUpdating = True End Sub

  • エクセル：マクロの手直し

    お世話になります。 以前ここで教えてもらったマクロのシート名のつけ方をすこし手直ししたいのでアドバイスください。 以下のマクロは、１シート目を決まった行数分に分割し各シートに振り分けるものです。今のマクロではシート名は分割1、分割2…分割10…などなりますが、Worksheets(1) のシート名＋3桁の連番（001,002…010…）などとしたい。 Worksheets(1) のシート名が「総務課」の場合、総務課001,総務課002…総務課010…となるのが理想です。 このようにするためにはマクロをどのように修正すればよいか教えてください。 Sub シート分割() 　Dim WS1 As Worksheet 　Dim WS2 As Worksheet 　Dim i As Integer 　Dim Bunkatsu As Integer 　Set WS1 = Worksheets(1) 'コピー元のデータシート 　Set WS2 = WS1 　Bunkatsu = 1 　Application.ScreenUpdating = False 　For i = 7 To WS1.Cells(Rows.Count, 1).End(xlUp).Row Step 25 　　Set WS2 = Worksheets.Add(After:=WS2) 　　WS2.Name = "分割" & Bunkatsu 　　WS1.Rows("1:6").Copy WS2.Cells(1, 1) 　　WS1.Rows(i & ":" & i + 24).Copy WS2.Cells(7, 1) 　　Bunkatsu = Bunkatsu + 1 　Next 　Application.ScreenUpdating = True End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する