このコードの修正を、何卒よろしくお願い致します。
- EXEL 2002のコピー元.xlsからコピー先.xlsにデータを転写するVBAコードの修正をお願いします。
- Forループを使用してコピー元.xlsの各シートのA1からC列のデータをコピー先.xlsのシート1の次の行に転写するコードの修正をお願いします。
- コピー元.xlsとコピー先.xlsには複数のシートが含まれており、全てのシートのデータを転写するコードの修正をお願いします。
- ベストアンサー
このコードの修正を、何卒よろしくお願い致します。
EXEL 2002 です。 下記コードの修正を、何卒よろしくお願い致します。 ------ Sub コピー() Dim i As Integer For i = 1 To 2 Workbooks("コピー元.xls").Activate Worksheets(i).Range("A1", Range("C65536").End(xlUp).Offset(0, 168)).Copy _ Destination:=Workbooks("コピー先.xls").Worksheets(Workbooks("コピー先.xls").Sheets(1).Range("A1")) Next i End Sub
- oshietecho-dai
- お礼率79% (263/330)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
こんにちは。 最初に、そのコードだけでは意味が伝わりませんから、何をしたいのか書いてくださいね。こちらは、想像でしかありません。 >Worksheets(i).Range("A1", Range("C65536").End(xlUp).Offset(0, 168)) このコードが違っています。 Rangeの親と、Rangeの中のRange は、親を合わせないといけません。 >Workbooks("コピー先.xls").Worksheets(Workbooks("コピー先.xls").Sheets(1).Range("A1")) 意味が分かりません。親と子が明示されているのですから、 Workbooks("コピー先.xls").Worksheets 別なオブジェクトを入れたら、Workbooks("コピー先.xls").Sheets(1) は、ハングします。 それに、それを直して、 Workbooks("コピー先.xls").Worksheets(1) にしても、同じところにコピーしたらヘンです。 こちらの予想サンプル '---------------------------------- Sub コピー() Dim i As Integer Workbooks("コピー元.xls").Activate For i = 1 To 2 With Workbooks("book1").Worksheets(i) .Range("A1", .Range("C65536").End(xlUp).Offset(0, 168)).Copy _ Workbooks("コピー先.xls").Worksheets(i).Range("A1") End With Next i End Sub
関連するQ&A
- ほんの少し変更しただけで、マクロが正常動作しないのは？
「てすと１」はきちんと、結果が反映されるが、 「てすと２」は、動作はするが、肝心のデータがコピーされません。 Range("B5", Range("B5").End(xlDown)) と、変更しただけです。 ただ、「てすと２」は、手動で Worksheets(i)をアクティヴにしておくと、きちんと結果が反映されます。 なぜなんでしょうか？ 何卒、ご教授お願い致します。 Sub てすと１() Dim i As Integer Windows("TEST.xls").Activate Sheets.Add after:=Worksheets(Worksheets.Count), Count:=1 On Error Resume Next For i = 1 To Worksheets.Count - 1 Worksheets(i).Range("C:C").Copy _ Destination:=Worksheets(Worksheets.Count).Range("IV4").End(xlToLeft).Offset(0, 1).EntireColumn Next i End Sub Sub てすと２() Dim i As Integer Windows("TEST.xls").Activate Sheets.Add after:=Worksheets(Worksheets.Count), Count:=1 On Error Resume Next For i = 1 To Worksheets.Count - 1 'Worksheets(i).Activate '左記を追記すると、きちんと結果が反映される Worksheets(i).Range("B5", Range("B5").End(xlDown)).Copy _ Destination:=Worksheets(Worksheets.Count).Range("IV4").End(xlToLeft).Offset(0, 1) Next i End Sub
- ベストアンサー
- オフィス系ソフト
- このコードの修正を教えてください !
下記コードが、動作しませんので、どのように修正すればよろしいのでしょか？ Sh.Range("A1").Select がエラーになるようですが、よくわかりません。 以上 何卒、よろしくお願いいたします。 ---------------- Sub 指定したシートだけに目的データをコピー() For Each sh In Workbooks("あ.xls").Sheets '下記シート３つは、手動にて挿入したシートで、場所は前後しています If sh.Name = "Sheet1" Or sh.Name = "Sheet2" Or sh.Name = "Sheet3" Then Workbooks("い.xls").Activate Sheets("Sheet3").Select Selection.CurrentRegion.Select Selection.Copy Workbooks("あ.xls").Activate Sh.Range("A1").Select ActiveSheet.Paste End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- コピー後に値のみ貼り付け エクセル、VBAの記述について
マクロ初心者です。 エクセルで選択範囲を指定後コピーし、 自動的に別のシートの末尾に貼り付けられるようにしたのですが、 この内容のまま「貼り付け」を「値のみ貼り付け」に訂正する場合 どのように変更すればいいのか、教えてくださると嬉しいです。 宜しくお願いいたします。 Sub 選択範囲をコピー後、指定シートの末尾に貼り付け Worksheets("sheet1").Activate Range("b11:I17").Copy Workbooks("book2.xls").Worksheets("Sheet1").Activate 行 = Range("B1").CurrentRegion.Rows.Count + 1 ActiveSheet.Paste _ Destination:=Workbooks("book2.xls").Worksheets("Sheet1").Range("B" & 行) End Sub
- ベストアンサー
- オフィス系ソフト
- このコードのチェックをお願い致します。
2種類のブックのデータを → 追加した１つのブックに貼り付けます。 下記 「'------ここからエラーになる----」 からエラーになります。 エラー番号 91 「オブジェクト変数またはWith ブロック変数が設定されていません」 以上 下記コードのチェックをお願い致します。 ------------------------------ Sub tes1() Dim fWord As String, fAdd, c, wb As Workbook fWord = "1" Set wb = Workbooks.Add(xlWBATWorksheet) Workbooks("ああ.CSV").Activate Rows("1:1").Select Selection.Insert Shift:=xlDown With Workbooks("ああ.CSV").Worksheets(1).Range("F:F") Set c = .Find(fWord, LookIn:=xlValues) If Not c Is Nothing Then fAdd = c.Address Do c.Offset(0, 2).Resize(8, 1).Copy wb.Worksheets(1).Range("B65536").End(xlUp). _ Offset(1, 0).PasteSpecial Paste:=xlAll, _ Transpose:=True Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> fAdd End If End With Application.CutCopyMode = False Call tes2 End Sub '-------------------- Sub tes2() Dim aWord As String, aAdd, c, wb As Workbook aWord = "1" Workbooks("いい.CSV").Activate With Workbooks("いい.CSV").Worksheets(1).Range("A:A") Set c = .Find(aWord, LookIn:=xlValues) If Not c Is Nothing Then aAdd = c.Address Do c.Offset(0, 23).Resize(1, 1).Copy '------ここからエラーになる------------------------ wb.Worksheets(1).Range("B65536").End(xlUp). _ Offset(1, 0).PasteSpecial Paste:=xlAll, _ Transpose:=True Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> aAdd End If End With Application.CutCopyMode = False End Sub
- ベストアンサー
- オフィス系ソフト
- 他Bookへの抽出
お世話になります。 開いているBook1からデータを抽出し、Book2へコピーしたいのですが、AdvancedFilterでエラーが出てしまいます。 何がまずいのかよくわかりません。 お分かりになる方、ご教授願います。 Private Sub Worksheet_Activate() Set myTbl = Workbooks("Book1.xls").Worksheets("Sheet1").Range("myTbl") Set myQry = Workbooks("Book2.xls").Worksheets("抽出条件").Range("A_抽出条件") Set sakiRng = Workbooks("Book2.xls").Worksheets("A").Range("A3：AR3") myTbl.AdvancedFilter xlFilterCopy, myQry, sakiRng ←ここでエラーになります。 Dim rw As Long '入力最終行 rw = Range("I65536").End(xlUp).Row With Application Range("I" & rw + 1) = .Sum(Range("I1:I" & rw)) Range("AO" & rw + 1) = .SumIf(Range("AP1:AP" & rw), "済", Range("AO1:AO" & rw)) Range("AQ" & rw + 1) = .Sum(Range("AQ1:AQ" & rw)) End With End Sub
- ベストアンサー
- オフィス系ソフト
- 横にコピーするには・・。
教えてください・・。 01.xls・02.xls・03.xlsとあり、その中のシート（01・02・03）をコピーして、全部というシートにまとめたいと思っています。 列にデータを追加したいのですが、行にデータが追加されてしまいます・・。 どうしたらいいのか教えてください。 01のシートがＡからＤまで 02のシートがＥからＧまで 03のシートがＨからＬまで とコピーをしたいと思っています・・。 --------- PathName = ThisWorkbook.Path & "\" ArrBook = Array("01.xls", "02.xls", "03.xls") For i = LBound(ArrBook) To UBound(ArrBook) Workbooks.Open PathName & ArrBook(i) Next Set WS(1) = Workbooks("01.xls").Worksheets("01") Set WS(2) = Workbooks("02.xls").Worksheets("02") Set WS(3) = Workbooks("03.xls").Worksheets("03") Set WS(4) = ThisWorkbook.Worksheets("全部") With WS(4) .Cells.ClearContents .Cells(1, 1) = "Ａ" .Cells(1, 2) = "B" .Cells(1, 3) = "C" .Cells(1, 4) = "D" .Cells(1, 5) = "E" .Cells(1, 6) = "F" .Cells(1, 7) = "G" .Cells(1, 8) = "H" .Cells(1, 9) = "I" .Cells(1, 10) = "J" .Cells(1, 11) = "K" .Cells(1, 12) = "L" .Cells(1, 13) = "M" .Cells(1, 14) = "N" .Cells(1, 15) = "O" .Cells(1, 16) = "P" .Cells(1, 17) = "Q" LastRow(1) = WS(1).Range("A65536").End(xlUp).Row LastRow(2) = WS(2).Range("A65536").End(xlUp).Row LastRow(3) = WS(3).Range("A65536").End(xlUp).Row For i = 1 To 3 LastRow(4) = .Range("A65536").End(xlUp).Row + 1 WS(i).Rows("2:" & LastRow(i)).Copy .Cells(LastRow(4), 1) LastRow(4) = .Range("A65536").End(xlUp).Row End With For i = LBound(ArrBook) To UBound(ArrBook) Workbooks(ArrBook(i)).Close SaveChanges:=False Next End Sub
- ベストアンサー
- オフィス系ソフト
- 「 このコード 」 のチェック を お願い致します。
下記コードは何とか動作しますが、チェックお願い致します。 １、 MsgBox "「 空白シート 」 は ありません。" の 追加編集が、よくわかりません。 ２、 １以外に、おかしな箇所をご教示お願い致します。 --------------------------- '「 ブック１ 」 に空白シートがあったら、そこへ貼り付ける Sub 空白シートへコピー() Dim ws As Worksheet For Each ws In Workbooks("ブック１.xls").Sheets If IsEmpty(ws.UsedRange) = True Then Workbooks("ブック２.xls").Activate Cells.Select Selection.Copy Workbooks("ブック１.xls").Activate ws.Select Range("A1").Select ActiveSheet.Paste Else MsgBox "「 空白シート 」 は ありません。" End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- インデックスが有効範囲に出ないと出る
下記のようなVBAを書きました。しかしインデックスが有効範囲にないとメッセージがでるのですが、どこがまちがっているでしょうか？？ Sub macro1() Dim i As Long Dim r As Long Worksheets("フェアリスト ").Select Worksheets("csv").Range("A:C").ClearContents For i = 2 To 50 Step 5 If Worksheets("フェアリスト").Cells(11, i + 1) <> "" Then r = Worksheets("フェアリスト").Cells(65536, i + 1).End(xlUp).Row Worksheets("フェアリスト").Range(Cells(11, i), Cells(r, i + 3)).Copy _ Destination:=Worksheets("csv").Range("B65536").End(xlUp).Offset(1) Worksheets("csv").Range("A65536").End(xlUp).Offset(1).Resize(r - 3, 1).Value = Worksheets("フェアリスト").Cells(8, i).Value End If Next i Worksheets("csv").Range("A1:C1").Delete shift:=xlShiftUp End Sub
- ベストアンサー
- オフィス系ソフト
- WorkbookのCopyについて
Workbookのコピーについて教えてください。 下記のマクロにセル内の数式もコピーしたいのですが、出来ないで困ってます。 値と数式をコピーする、マクロを入れると指定した範囲にコピーされません。 Sub CopyWorkbookToWorkbook() Windows("sheet2.xls").Activate Workbooks.Open Filename:="D:\book1.xls" Workbooks("book1.xls").Worksheets("sheet1").Range("A6:k1000").Copy Workbooks("book2.xls").Worksheets("sheet1").Range("A6").PasteSpecial Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False,Transpose:=False Workbooks("book1.xls").Close End Sub よろしくお願いします。
- ベストアンサー
- その他MS Office製品
- ＶＢＡ 他のエクセルファイルデータを読み込む
エクセルのＶＢＡに関する質問です。 かじった程度の知識でがんばってはみたのですが、以下のことがどうしてもできません。 集計ファイルと、それぞれが入力するファイルがいくつか（具体的には１Ａ.xls、１Ｂ.xls、２Ａ.xls、２Ｂ.xlsといった数字とアルファベットの組み合わせ）あります。 入力ファイルに書かれているデータを集計ファイルに取り込もうと考えています。 入力ファイル名が（１.xls，２.xls・・・）の様に数字だけの取り込みはできました。 m = Val(UserForm2.TextBox1.Text) For i = 1 To m On Error GoTo myError Workbooks.Open Filename:="C:" & i & ".xls", UpdateLinks:=0 Range("f65536").End(xlUp).Activate Workbooks(i & ".xls").Activate Sheets("入力ファイル").Select Range("A3:X52").Select Application.CutCopyMode = False Selection.Copy Workbooks("集計ファイル.xls").Activate Sheets("DB").Activate Range("a65536").End(xlUp).Activate Selection.Offset(1).Select ActiveSheet.Paste Range("a65536").End(xlUp).Select Workbooks(i & ".xls").Close SaveChanges:=False myError: Next i Application.DisplayAlerts = True こんな感じです。 これを、数字だけでなく数字＋アルファベット.xlsのファイル名にしてデータを取り込むにはどうすればいいのでしょうか？色々と試行錯誤をしたり、ネットで調べたりしたのですが、詰んでしまいました。 どなたかお助け下さい。
- ベストアンサー
- Visual Basic
お礼
こんばんわ、 ご回答、誠に有難うございました。 予想されたとおりでございました。 私自身、四苦八苦して、もお限界でしたので、あせって投項し、説明が不十分となってしまった次第でございました。