VBAでcopy,pasteからsave,closeしたい | |
---|---|
[195983] VBAでcopy,pasteからsave,closeしたい- ■親トピック/記事引用/メール受信=OFF■ □投稿者/ p090315 -(2023/10/18(19:48)) □U R L/ 70歳のVBA初心者です。 お手数掛けますが、よろしくお願いします。 [コード] Private Sub Workbook_Open() Dim i As Integer Dim j As Integer Dim SaveFileName As String For j = 1 To 2 SaveFileName = Mid(Range("A" + Trim(Str(j))).Value, 59, 8) & ".xlsx" Workbooks.Open Filename:=Range("A" + Trim(Str(j))).Value Cells.Select Selection.Copy Workbooks.Add Range("A1").Select ActiveSheet.Paste MsgBox "Please paste." Application.CutCopyMode = False ChDir "C:\作業ファイル" ActiveWorkbook.SaveAs Filename:=SaveFileName ActiveWorkbook(SaveFileName).Close Windows("PEFileList.xlsm").Activate Workbooks(Range("A" + Trim(Str(j))).Value).Close 'MsgBox j 'ActiveWorkbook.Close Next j End Sub やりたい事 セルA1からA50くらいまでに入ったPath名のExcelファイルを一つずつ開き、 全セルをcopyし、 新しいbookを作成して、copyしたセルを値、書式ともPasteし、 上記Path名の一部分をファイル名とするxlsxファイルを"c:\作業ファイル"フォルダーに saveして、ファイルをcloseする。 上記コードはデバッグのために、1行目と2行目のみで回している。 上記コードを実行するとActiveSheet.Pasteの行で下記errorが発生する。 対応方法をご教示お願いします。 実行時エラー'1004' アプリケーション定義またはオブジェクト定義のエラーです。 この記事にはVBAのコードが含まれています。 緑の太文字→注釈 茶色の太文字→条件分岐 赤の太文字→ループ 青の太文字→その他 ++++++++++++++++++++ OS ⇒OTHER Version⇒OTHER ++++++++++++++++++++ |
[195984] Re[1]: VBAでcopy,pasteからsave,closeしたい- ■記事引用/メール受信=OFF■ □投稿者/ 半平太 -(2023/10/19(17:21)) □U R L/ 一見する限り、エラーが起きそうにないですけどねぇ・・ jが1の時から発生するんですか? それとも2になってからですか? |
[195985] Re[2]: VBAでcopy,pasteからsave,closeしたい- ■記事引用/メール受信=OFF■ □投稿者/ ヘンリー -(2023/10/19(19:12)) □U R L/ >一見する限り、エラーが起きそうにないですけどねぇ・・ 仰る通りですね。 そこで、自分なりにサンプルを作って試した結果を、 以下の様にまとめました。 【対処法】 >Range("A1").Select の部分をなくすか、 ActiveSheet.Range("A1").Select で解消できると思います。 又、「ActiveSheet.Range("A1").Select」 で解消できるという事は、 Activeではない「Range("A1")」を選択していると思われます。 さらに、この行のエラー解除しても、 別の所でもエラーがでる可能性があります。 Activeセルと選択セルは別物です。 複数のBook、複数のSheetにまたがって使用する場合は、 「ブックオブジェト.シートオブジェクト.レンジオブジェクト」 という様に指定します。 例) Thisworkbook.Activesheet.Range("A1") コンピュータは「察する」という事ができません。 一つ一つ細かく指定してく必要があります。 ※ちなみに「AI」は「察しているように見せかける」 というようなアルゴリズムが組まれているだけです。 サンプルコードを作ってみました。 Private Sub Sample() Dim i As Integer Dim j As Integer Dim SaveFileName As String Dim wbSource As Workbook 'Pathの一覧があるワークブックオブジェクト用の変数を宣言 Dim wsSource As Worksheet '上記ワークブックオブジェクトのワークシートオブジェクト用の変数を宣言 Dim wbCopySource As Workbook 'コピー元のワークブックオブジェクト用の変数を宣言 Dim wsCopySource As Worksheet '上記ワークブックオブジェクトのワークシートオブジェクト用の変数を宣言 Dim wbNewBook As Workbook 'コピー先のワークブックオブジェクト用の変数を宣言 Dim wsNewSheet As Worksheet '上記ワークブックオブジェクトのワークシートオブジェクト用の変数を宣言 Set wbSource = ThisWorkbook 'Pathの一覧があるワークブックオブジェクトを生成 Set wsSource = wbSource.ActiveSheet '上記のワークブックオブジェクトのアクティブシートオブジェクトを生成 '上記の様にブックとシートを、オブジェクト変数に入れていきながら、 'どのブックのどのシートというのを、一つ一つ指定して実行するように指示します。 For j = 1 To 2 SaveFileName = Mid(Range("A" + Trim(Str(j))).Value, 9, 6) & ".xlsx" Set wbCopySource = Workbooks.Open(Filename:=wsSource.Range("A" + Trim(Str(j))).Value) Set wsCopySource = wbCopySource.ActiveSheet wsCopySource.Cells.Select Selection.Copy Set wbNewBook = Workbooks.Add Set wsNewSheet = wbNewBook.ActiveSheet wsNewSheet.Range("A1").Select wsNewSheet.Paste MsgBox "Please paste." Application.CutCopyMode = False ChDir "D:\1019\作業用" ActiveWorkbook.SaveAs Filename:=SaveFileName '←このコードだと"***.xlsx.xlsx"というファイル名になります ActiveWorkbook.Close wbCopySource.Close wbSource.Activate Next j Set wbSource = Nothing Set wsSource = Nothing Set wbCopySource = Nothing Set wsCopySource = Nothing Set wbNewBook = Nothing Set wsNewBook = Nothing FileCopy End Sub >70歳のVBA初心者です。 という事ですので、 以下の事についても調べてみてください。 ・VBA オブジェクト変数 ・VBA FileCopyステートメント ・VBA データの最終行の取得 ・VBA データの最終列の取得 ・VBA 値の代入 ・VBA Application.ScreenUpdating ・VBA インデント この記事にはVBAのコードが含まれています。 緑の太文字→注釈 茶色の太文字→条件分岐 赤の太文字→ループ 青の太文字→その他 |
[195986] Re[3]: VBAでcopy,pasteからsave,closeしたい- ■記事引用/メール受信=OFF■ □投稿者/ ヘンリー -(2023/10/19(19:14)) □U R L/ すみません。 >SaveFileName = Mid(Range("A" + Trim(Str(j))).Value, 9, 6) & ".xlsx" の部分が自分で作ったサンプルのままでした。 SaveFileName = Mid(Range("A" + Trim(Str(j))).Value, 59, 8) & ".xlsx" に訂正しそびれただけです。 |
[196002] Re[4]: VBAでcopy,pasteからsave,closeしたい- ■ / 記事引用/メール受信=OFF■ □投稿者/ p090315 -(2023/10/26(22:23)) □U R L/ 回答を寄せていただいた皆様、ありがとうございました。 試してみるのに時間がかかり、お返事が遅くなりました。 「ヘンリー」さんのサンプルプログラムを使って、ファイル名やフォルダー名を整えて 下記(コード1)のようにして実行してみました。エラーは発生しませんでしたが この中の「D:\作業ファイル」の中にファイルは出来ていませんでした。 原因はわかりません。 その後、息子の助けを得て、Microsoft Edgeのコパイロットでコードを生成し、 (コード2)のようにして、現在実用しています。(途中にシートの整形が入っています) お時間を取らせてしまった方々には、申し訳ありません。 以下、参考までにコードを示します。 (コード1) Sub Sample() Dim i As Integer Dim j As Integer Dim SaveFileName As String Dim wbSource As Workbook 'Pathの一覧があるワークブックオブジェクト用の変数を宣言 Dim wsSource As Worksheet '上記ワークブックオブジェクトのワークシートオブジェクト用の変数を宣言 Dim wbCopySource As Workbook 'コピー元のワークブックオブジェクト用の変数を宣言 Dim wsCopySource As Worksheet '上記ワークブックオブジェクトのワークシートオブジェクト用の変数を宣言 Dim wbNewBook As Workbook 'コピー先のワークブックオブジェクト用の変数を宣言 Dim wsNewSheet As Worksheet '上記ワークブックオブジェクトのワークシートオブジェクト用の変数を宣言 Set wbSource = ThisWorkbook 'Pathの一覧があるワークブックオブジェクトを生成 Set wsSource = wbSource.ActiveSheet '上記のワークブックオブジェクトのアクティブシートオブジェクトを生成 '上記の様にブックとシートを、オブジェクト変数に入れていきながら、 'どのブックのどのシートというのを、一つ一つ指定して実行するように指示します。 For j = 1 To 2 SaveFileName = Mid(Range("A" + Trim(Str(j))).Value, 32, 8) & ".xlsx" Set wbCopySource = Workbooks.Open(Filename:=wsSource.Range("A" + Trim(Str(j))).Value) Set wsCopySource = wbCopySource.ActiveSheet wsCopySource.Cells.Select Selection.Copy Set wbNewBook = Workbooks.Add Set wsNewSheet = wbNewBook.ActiveSheet wsNewSheet.Range("A1").Select wsNewSheet.Paste 'MsgBox "Please paste." Application.CutCopyMode = False ChDir "D:\作業ファイル" ActiveWorkbook.SaveAs Filename:=SaveFileName '←このコードだと"***.xlsx.xlsx"というファイル名になります ActiveWorkbook.Close wbCopySource.Close wbSource.Activate Next j Set wbSource = Nothing Set wsSource = Nothing Set wbCopySource = Nothing Set wsCopySource = Nothing Set wbNewBook = Nothing Set wsNewBook = Nothing 'FileCopy End Sub (コード2) Sub CopyExcelFiles() Dim i As Integer Dim sourceWorkbook As Workbook Dim targetWorkbook As Workbook Dim sourcePath As String Dim targetPath As String Dim newfilename As String Application.CutCopyMode = False Application.DisplayAlerts = False For i = 1 To 100 sourcePath = Range("A" & i).Value If sourcePath = "" Then Exit Sub End If Set sourceWorkbook = Workbooks.Open(sourcePath) Set targetWorkbook = Workbooks.Add sourceWorkbook.Sheets(1).UsedRange.Copy targetWorkbook.Sheets(1).Range("A1").PasteSpecial xlPasteAll targetWorkbook.Sheets(1).Cells(1, 1).PasteSpecial (xlPasteColumnWidths) Columns("A").Hidden = True Columns("D:E").Select Selection.EntireColumn.Hidden = True ActiveWindow.Zoom = 140 sourceWorkbook.Close False newfilename = Mid(sourcePath, 32, 8) targetPath = "H:\ポストエディット\翻訳案件\231011\test作業ファイル\" & newfilename & ".xlsx" targetWorkbook.SaveAs targetPath, xlOpenXMLWorkbook targetWorkbook.Close False Next i Application.DisplayAlerts = True Application.CutCopyMode = True End Sub この記事にはVBAのコードが含まれています。 緑の太文字→注釈 茶色の太文字→条件分岐 赤の太文字→ループ 青の太文字→その他 ++++++++++++++++++++ OS ⇒OTHER Version⇒OTHER ++++++++++++++++++++ |
このトピックに書きこむ |
---|