エクセルVBA ブック間のコピー

このQ&Aのポイント
  • エクセルVBAでブック間のコピーを行う方法を学んでいますが、コンパイルエラーが発生してしまいます。
  • Opentxtマクロは正常に動作していますが、Copyマクロで問題が発生しています。
  • 変数の型などを確認してもエラーの原因がわかりません。Excel 2007を使用しています。
回答を見る
  • ベストアンサー

エクセルVBA ブック間のコピー

選択したテキストファイルをエクセルで開いたコピーし、 もう一つ開いたエクセルファイルにペーストするというマクロをVBAで 作成していますが、つまずいてしまいました。 ----------------------------------- Dim wb1 As String Dim wb2 As String Sub Opentxt() wb1 = Application.GetOpenFilename("テキストファイル,*.txt") If wb1 <> "False" Then Workbooks.OpenText Filename:=wb1, DataType:=xlDelimited, comma:=True End If End Sub Sub Copy() Dim LastRow As Long wb2 = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") If wb2 <> "False" Then Workbooks.Open wb2 LastRow = wb2.Sheets("一覧表").Range("A" & Rows.Count). End(xlUp).Row wb2.Sheets("一覧表").Range("A5:A" & lastRow).Copy _ wb1.Sheets("Sheet1).Range("B33") End If End Sub ----------------------------------- Opentxtの方は問題ないですが、Copyの方を実行すると wb1とwb2で引っかかって「コンパイルエラー/ 修飾子が不正です」と 表示されて、エラーになってしまいます。 この場合変数の型などがおかしいのでしょうか? excel2007を使用しています。 よろしくお願いします。

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

  • ベストアンサー
  • mt2008
  • ベストアンサー率52% (885/1701)
回答No.1

変数「wb1」「wb2」は文字列型として宣言していますので、wb2.Sheets("一覧表") こんな使い方は出来ません。この様に使うためにはWorkbookオブジェクトにする必要があります。 次に、質問文が正しいとすると、Copy関数の使い方が逆です。 例:Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("B2") Sheet1のセルA1からSheet2のセルB2にコピー また、開いたテキストファイルのシート名を「Sheet1」としていますが、テキストファイルはファイル名がシート名になります。 シート名を指定するよりはSheets(1)の様にして1番目のシートと指定した方が良いと思います。 また、悪いわけではありませんがCopyの様に他でも良く使う名前をプロシージャ名に使うのは混乱の元です(以下の例ではDataCopyに改名しました)。なるべく使わない方が良いです。 Dim wb1 As String Dim wb2 As String Dim wWb1 As Workbook Dim wWb2 As Workbook Sub Opentxt()   wb1 = Application.GetOpenFilename("テキストファイル,*.txt")   If wb1 <> "False" Then     Workbooks.OpenText Filename:=wb1, DataType:=xlDelimited, comma:=True     Set wWb1 = ActiveWorkbook   End If End Sub Sub DataCopy()   Dim LastRow As Long   wb2 = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")   If wb2 <> "False" Then     Workbooks.Open wb2     Set wWb2 = ActiveWorkbook     LastRow = wWb2.Sheets("一覧表").Range("A" & Rows.Count).End(xlUp).Row     wWb1.Sheets(1).Range("B33").Copy wWb2.Sheets("一覧表").Range("A" & LastRow + 1)   End If End Sub

garigarisama
質問者

お礼

とても分かりやすくご説明いただきまして、無事解決できました。 質問以外にもご指摘をいただき、ありがとうございました。

その他の回答 (1)

  • qualheart
  • ベストアンサー率41% (1451/3486)
回答No.2

前の方の回答でOKだと思いますが、敢えて言うならCopyはあまり使わない方が良いと思います。 クリップボードを使うのは重くなるだけなので。 セルの値を他のセルに入力したい場合は、単純に.valueで値を参照すればできます。 コピーを実行している部分を、 wWb2.Sheets("一覧表").Range("A" & LastRow + 1).Value = wWb1.Sheets(1).Range("B33") のように、 値を入れるセル.Value=値の参照元セル とすればOKです。 ご参考まで。

garigarisama
質問者

お礼

ありがとうございます。 どちらも試してみて、具合の良い方を選択したいと思います。

関連するQ&A

  • VBAについて質問です。

    下記の様なコードがあり、EXCELのデータを別EXCELの指定シートの日付欄と合致させ、データを 貼り付けるという内容です。 ★部の所で実行時エラー '1004':RangeクラスのSelectメソッドが失敗しました。となってしまいます。 なぜか不明確なためアドバイスを宜しくお願い致します。 K2 = Range("K2") K3 = Range("K3") Dim wb As String Dim dy As String Dim dy2 As String Dim a As String dy = Range("K5") dy2 = Range("M1") Range("R5:R41").Copy wb = "D:\Documents and Settings\ssk\デスクトップ\" & dy & ".xls" Workbooks.Open (wb) Workbooks(dy & ".xls").Sheets("data").Select For n = 2 To 100 Step 1 a = Cells(1, n).Value If Cells(1, n).Value = dy2 Then Worksheets("data").Activate Cells(3, n).PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False End If Next 'err1: 'Excel.Application.CutCopyMode = False 'With ThisWorkbook 'If Workbooks.Count > 1 Then '.Saved = True ' .Close False ' Else ' .Saved = True ' Application.Quit '.Close ' End If 'End With End Sub

  • EXCEL VBAについて質問です。

    EXCEL VBAについて質問です。 アドバイスを宜しくお願い致します。 現状開いているシートの日付を参照し、新しく開いたシートの日付とあっているセル下部に 貼り付けを行おうとしています。 条件的にはあっている気がしますが、なぜか貼りつきません。 アドバイス宜しくお願いたします。 元シート日付 2014/06/01 添付画像が貼り付け先のEXCELとなっております。 以上宜しくお願い致します。 Dim s As Long Dim wb As String Dim dy2 As String Dim a As String  dy2 = Range("M1")    元EXCELの日付を参照  Range("M5:R41").Copy  元EXCELのデータをコピーする。 wb = "D:\Documents and Settings\ssk\デスクトップ\まとめ.xls"   ’ Workbooks.Open (wb)    新しいブックを開く。 Sheets("data").Select    対象のシートを選択 For n = 2 To 187 Step 6 If Cells(1, n).Value = dy2 Then 元ブックの日付と新しく開いたブックの日付を参照しあっていれば下記のようにはりつけする。 Cells(3, n).Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False End If Next End Sub

  • エクセルVBAでBOOKを開く際の処理

    エクセルVBAでBOOKを開く際の処理 エクセル2000です。 VBAで特定のフォルダー内のBOOKを開き、1枚目のシートSheets(1)のデータを読み込んで別BOOK(マクロを記載したBOOK)にコピペしたら保存せず閉じるコードを下記のように書きました。(かなり簡略化しましたが) これで作動するのですが、万一、そのフォルダー内のBOOKが開いていても1枚目のシートのデータを読み込み後、閉じられてしまいます。 BOOKが開いていれば、その開いていたBOOKは閉じず、先に進むようにするにはどのように直せばいいでしょうか? Sub TEST01()   Dim mb As Workbook, wb As Workbook   Dim myfd As String, fnme As String, ans As Byte, i As Long      ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね?", vbYesNo + vbQuestion, "( ̄∇ ̄) ? ")   If ans = vbNo Then     MsgBox "それじゃだめです。", vbCritical, "Σ( ̄ロ ̄lll)"     Exit Sub   End If      Set mb = ThisWorkbook   myfd = mb.Path   fnme = Dir(myfd & "\*.xls")      Do Until fnme = Empty     If fnme <> mb.Name Then       Set wb = Workbooks.Open(myfd & "\" & fnme)       i = i + 1       mb.Sheets(1).Cells(i, 1) = wb.Sheets(1).Range("S10")       wb.Close (False) '保存せずに閉じる     End If     fnme = Dir   Loop        Set mb = Nothing   Set wb = Nothing   MsgBox i End Sub

  • VBAを実行するとエクセルが落ちる

    同一フォルダ内にあるCSVデータを一つのエクセルにワークブックにまとめるため CSVデータを開いて、各シートに値を貼り付けるVBAを作成しました デバックモードで1行毎に実行するとエクセルが落ちることはありませんが 普通に実行するとエクセルが閉じてしまいます 原因が分からないためご指摘いただけると幸いです Win7のOffice2013です。 Sub contents() Sheets("01").Select Sheets("01").Cells.Select Selection.ClearContents Dim ShA As Worksheet Dim FileA As String Set ShA = ThisWorkbook.Sheets("01") ChDir "C:\Users\Public\Documents" FileA = "C:\Users\Public\Documents\01.csv" If FileA <> "False" Then Workbooks.OpenText Filename:=FileA, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlTextQualifierNone, Comma:=True ActiveSheet.Cells.CurrentRegion.Copy Destination:=ShA.Range("A1") ActiveWorkbook.Close False End If Set ShA = Nothing Sheets("02").Select Sheets("02").Cells.Select Selection.ClearContents Dim ShB As Worksheet Dim FileB As String Set ShB = ThisWorkbook.Sheets("02") ChDir "C:\Users\Public\Documents" FileB = "C:\Users\Public\Documents\02.csv" If FileB <> "False" Then Workbooks.OpenText Filename:=FileB, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlTextQualifierNone, Comma:=True ActiveSheet.Cells.CurrentRegion.Copy Destination:=ShB.Range("A1") ActiveWorkbook.Close False End If Set ShB = Nothing Sheets("03").Select Sheets("03").Cells.Select Selection.ClearContents Dim ShC As Worksheet Dim FileC As String Set ShC = ThisWorkbook.Sheets("03") ChDir "C:\Users\Public\Documents" FileC = "C:\Users\Public\Documents\03.csv" If FileC <> "False" Then Workbooks.OpenText Filename:=FileC, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlTextQualifierNone, Comma:=True ActiveSheet.Cells.CurrentRegion.Copy Destination:=ShC.Range("A1") ActiveWorkbook.Close False End If Set ShC = Nothing End Sub

  • エクセルVBAでBOOKに読み取りパスワード設定

    エクセル2013です。 以下のコードで指定した任意のフォルダ内のエクセルに読み取りパスワードを設定できました。 しかし、そのフォルダの下にサブフォルダーがあった場合にサブフォルダ内のBOOKは対象になりません。どのように直せばサブフォルダも対象にできるようになるでしょうか?教えてください。 Sub TEST01()   Dim myfdr As String, fname As String   Dim mb As Workbook, wb As Workbook   Dim n As Long   With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定      If .Show = True Then       myfdr = .SelectedItems(1)     Else       MsgBox "キャンセルします。"       Exit Sub     End If   End With   Set mb = ThisWorkbook 'このコピー先ブックをmbとする。   fname = Dir(myfdr & "\*.xls*") 'フォルダ内のExcelブックを検索   n = 2   Do Until fname = Empty '全て検索     Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。     With mb.Sheets("Sheet1") '転記       .Cells(n, "B").Value = wb.FullName       .Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value     End With     n = n + 1 'カウント     Application.DisplayAlerts = False     wb.SaveAs Filename:=wb.FullName, Password:="emaxemax"     wb.Close     Application.DisplayAlerts = True     fname = Dir 'フォルダ内の次のExcelブックを検索   Loop '繰り返す   MsgBox n - 2 & "件処理しましました。" End Sub

  • Excel VBA連続コピー、貼付処理について

    特定のフォルダ内に格納されている複数のExcelファイルの「sheet1」シートのデータを 所定のExcelファイルにコピー&ペーストしたいのですが、うまくいきません。 (貼付先のファイルを閉じようとするとエラーが発生します。) どうすればできるようになるでしょうか? ご教授の程よろしくお願いいたします。 -------------------------------------------------------------------- Sub copy_test() Dim myPath As String Dim copyFile As String Dim pasteFile As String Dim n As Long myPath = "C:\copy\" copyFile = Dir(myPath & "*.xls*") pasteFile = "C:\paste\paste_data.xlsx" n = 2 Do Until copyFile = "" Workbooks.Open Filename:=myPath & copyFile Workbooks(copyFile).Worksheets("sheet1").Range("A2:L201").Copy Workbooks.Open Filename:=pasteFile 'Workbooks(pasteFile).Worksheets("paste_data").Active Range("B1").Select Selection.End(xlDown).Select Selection.End(xlToLeft).Select Selection.End(xlUp).Select ActiveCell.Offset(1, 0).Select ActiveSheet.Paste ActiveWorkbook.Save Workbooks(pasteFile).Close False Application.CutCopyMode = False Workbooks(copyFile).Close False n = n + 999 copyFile = Dir() Loop End Sub ---------------------------------------------------------------------------------

  • エクセルVBAで困っています。

     エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから各項目ごとに別Sheetに振り分けたいと思っています。  ある方にエクセルVBAで作って頂いたのですが、最初作って頂いた時の項目は会費、会議費、事務費の3つでした。その項目を9つに増やしたいと思っています。又、全てのSheetで1行目には銀行名や項目名を入れたいので2行目から日付、内容・・・といったように入力したいです。そうした場合、どこをどう変更したらよいのか分かりません。自分がわかる範囲で(適当ですが)挑んでみたのですが、私自体VBAについて全く無知のため何が何だかサッパリです。どなたか教えて頂くことはできないでしょうか。ちなみに文字数に制限があったため改行やスペースなどは入れていません。見難いとは思いますがよろしくお願いします。どうか皆様のお知恵を貸して頂けると幸いです。 Option Explicit Sub Teller() '【考え方】Sheet1とSheet2を入力と考える。 'マクロを実行したときに、Sheet1,2を元に、項目別に振り分ける。 Const BankName1 As String = "○銀行" Const BankName2 As String = "(チェック)銀行" Const tempSheet As String = "一時シート" Dim classify(9) As String Dim title(5) As String Dim i As Long Dim j As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim findUpper As Long Dim findLower As Long Dim keyword As String Dim ws As Worksheet Dim Bank1 As Worksheet Dim Bank2 As Worksheet Dim Temp As Worksheet Set Bank1 = Worksheets(BankName1) Set Bank2 = Worksheets(BankName2) '【振り分ける項目名】 classify(1) = "会費" classify(2) = "会議費" classify(3) = "事務費" classify(4) = "事業費" classify(5) = "研修費" classify(6) = "報償費" classify(7) = "慶弔費" classify(8) = "予備費" classify(9) = "積立金" '【1行目に記載する見出し】 title(1) = "日付" title(2) = "内容" title(3) = "収入" title(4) = "支出" title(5) = "残高" '画面更新を停止 Application.ScreenUpdating = False '最終行取得 Bank1.Select lastRow1 = Cells(Rows.Count, 1).End(xlUp).Row Bank2.Select lastRow2 = Cells(Rows.Count, 1).End(xlUp).Row 'シートを作る For i = 1 To 3 Call MakeNewSheet_As_ThisName(classify(i)) For j = 1 To 5 Cells(1, j) = title(j) Next j Next i Call MakeNewSheet_As_ThisName(tempSheet) Cells.ClearContents Set Temp = Worksheets(tempSheet) '一時シートに、銀行1のデータと銀行2のデータをコピーする。 Bank1.Select Bank1.Range(Cells(3, 1), Cells(lastRow1, 5)).Copy Temp.Select Temp.Range(Cells(1, 1), Cells(lastRow1 - 2, 5)).PasteSpecial Bank2.Select Range(Cells(3, 1), Cells(lastRow2, 5)).Copy Temp.Select Cells(lastRow1 - 1, 1).PasteSpecial 'ソートする。 '第一優先キー:B列。[項目]昇順。 '第二優先キー:A列。[日付]昇順。 Range("A1:E" & (lastRow1 + lastRow2 - 4)).Select With ActiveWorkbook.Worksheets(tempSheet).Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第一キー .SortFields.Add Key:=Range("A1:A" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第二キー .SetRange Range("A1:E" & (lastRow1 + lastRow2 - 4)) .Apply End With For i = 1 To 3 keyword = classify(i) findUpper = 0 findLower = 0 '上から探す For j = 1 To lastRow1 + lastRow2 - 4 Step 1 If Cells(j, 2) = keyword Then findUpper = j Exit For End If Next j If findUpper > 0 Then '下から探す For j = lastRow1 + lastRow2 - 4 To 1 Step -1 If Cells(j, 2) = keyword Then findLower = j Exit For End If Next j 'コピー Range(Cells(findUpper, 1), Cells(findLower, 5)).Copy Sheets(keyword).Select Range("A2").Select ActiveSheet.Paste Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft Sheets(tempSheet).Select End If Next i '一時シートの削除 Application.DisplayAlerts = False Temp.Delete Application.DisplayAlerts = True 'アクティブセルをA1にしておく For Each ws In Worksheets Sheets(ws.Name).Select 'シート選択 Application.CutCopyMode = False Range("A1").Select Next ws Bank1.Select '画面更新を行う Application.ScreenUpdating = True MsgBox "実行しました" End Sub Sub MakeNewSheet_As_ThisName(ByVal GivenName As String) 'シートの有無を確認し、無ければ作る Dim exist_flag As Boolean Dim ws As Worksheet exist_flag = False For Each ws In Worksheets If UCase(ws.Name) = UCase(GivenName) Then 'シートが存在する場合 exist_flag = True Exit For End If Next ws 'シートを作成 If GivenName = "" Then MsgBox "空白名のシートは作れません。" ElseIf exist_flag = False Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = GivenName End If Sheets(GivenName).Select 'シート選択 End Sub

  • エクセルVBAで作成した別ブックにVBAを記述したい

    VBAで別ファイルの作成は下記で出来ているのですが、出来上がったファイルにVBAを記述する方法がわかりません。 具体的には一番下のSub TEST()を新しいブックの標準モジュールに記述したいのと、sheet1に Private Sub Worksheet_Change(ByVal Target As Range) MsgBox "ChangeTEST" End Sub を入れたいです。 また Private Sub Workbook_Open() MsgBox "OpenTEST" End Sub も入れたいのです。 どうぞご教示ください。 Sub 複製() Dim wb As Workbook, sc As Integer sc = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 Set wb = Workbooks.Add Application.SheetsInNewWorkbook = sc wb.Sheets("Sheet1").Select ThisWorkbook.Sheets("Sheet1").Cells.Copy wb.Sheets("Sheet1").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Buttons.Add(123, 195, 68.25, 15).Select Selection.OnAction = "TEST" Selection.Characters.Text = "TEST" ActiveWorkbook.Close ThisWorkbook.Activate Sheets("Sheet1").Select End Sub Sub TEST() MsgBox "TEST!!" End Sub よろしくお願いします。

  • エクセルVBAでのエラー

    おはようございます。 昨日ここでいろいろ教えていただき、300のエクセルファイルから特定の範囲のデータ抽出方法を書いてみたのですが、セルが多すぎて実行できません、というエラーがでてしまいます。 これはどのように解消すればよろしいのでしょうか? Sub Test() Dim FPath1 As String, FPath2 As String Dim FName As String, myBook As String Const startROW As Long = 14, lastROW As Long = 20 Const startCOL As Long = 8, lastCOL As Long = 10 Const shtNAME As String = "sheet1" Application.ScreenUpdating = False FPath1 = "D:\MR5567\" FPath2 = "D:\New Microsoft Excel Worksheet\" Workbooks.Add myBook = ActiveWorkbook.Name FName = Dir$(FPath1 & "*.xls") Do While FName <> "" Workbooks.Open Filename:=FPath1 & FName ActiveWorkbook.Sheets.Select Sheets(1).Activate Sheets.Copy After:=Workbooks(myBook).Sheets(Sheets.Count) Workbooks(FName).Activate Application.DisplayAlerts = False ActiveWorkbook.Close FName = Dir$ Loop ActiveWorkbook.SaveAs Filename:=FPath2 & "Renketsu.xls", FileFormat:=xlNormal ActiveWorkbook.Close Application.ScreenUpdating = True End Sub

  • Excelのブック間の串刺し計算について

    Excelのブック間の串刺し計算について VBA超初心者です。同じフォルダ内にファイルがいくつかあり、同じ形式で、sheet1のB4のセルに計があったとして、それをブック間で串刺し集計したいのですが、うまくいきません。どこが悪いのかもわからず、困り果ててます。ご指導お願いします。 Sub BookShuukei() Dim FileName As String Dim Total As Integer Dim OpenedBook As Workbook Dim IsBookOpen As Boolean FileName = Dir("*.xls") Application.ScreenUpdating = False Do While FileName <> "" If FileName <> ThisWorkbook.Name Then IsBookOpen = False For Each OpenedBook In Workbooks If OpenedBook.Name = FileName Then IsBookOpen = True Exit For End If Next If IsBookOpen = False Then Workbooks.Open (FileName) End If Total = Total + Workbooks(FileName).Sheets(1).Range("B4").Value If IsBookOpen = False Then Workbooks(FileName).Close End If End If FileName = Dir() Loop Application.ScreenUpdating = True MsgBox (Total) End Sub