質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.49%

選択範囲のコピーと別ファイルへのペースト

解決済

回答 3

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 1,133

score 64

前提・実現したいこと

VBAを使って、複数ファイルの内容を1つのファイルに統合するプログラムを書こうとしています。

発生している問題・エラーメッセージ

元ファイルの内容をコピーして、新しいブックのシートにペーストするコードの部分でエラーが発生します。

実行時エラー'438'
オブジェクトは、このプロパティまたはメソッドをサポートしていません。

というエラーが発生します。

該当のソースコード

デバッグすると下記の行が指定されます。

.Range(.Cells(1, 1), .Cells(EndRow, Endcolumn)).Copy Workbooks(NewBook).Wroksheets(NewSht).Rows(1)


全体のソースは下記となります。

Sub IntegPro()


'変数宣言

    Dim MacroBook As String
    Dim MacroSht As String
    Dim InputPath As String
    Dim OutputPath As String
    Dim Outputfile As String
    Dim InputFile As String
    Dim i As Integer
    Dim NewBook As String
    Dim NewSht As String
    Dim EndRow As Long
    Dim Endcolumn As Integer
    Dim DataBook As String
    Dim Datasht As String

'実行ファイルとシートの定義
        MacroBook = ActiveWorkbook.Name
        MacroSht = ActiveSheet.Name

'新規ブックを作成し、それのブックとシートを定義する
    Workbooks.Add
    NewBook = ActiveWorkbook.Name
    NewSht = ActiveSheet.Name

'入力パスや出力パス、出力ファイルの定義
    With Workbooks(MacroBook).Worksheets(MacroSht)
    .Activate
    InputPath = .Cells(2, 3).Value & "\"
    OutputPath = .Cells(3, 3).Value & "\"
    Outputfile = .Cells(4, 3).Value
    End With

'入力ファイルを定義
    i = 0
    Do While Workbooks(MacroBook).Worksheets(MacroSht).Cells(7 + i, 3).Value <> ""

    'ファイルを開く
        Workbooks.Open InputPath & Workbooks(MacroBook).Worksheets(MacroSht).Cells(7 + i, 3).Value

    '定義する
        DataBook = ActiveWorkbook.Name
        Datasht = ActiveSheet.Name

        'データファイルの最終行と最終列を記憶する
        With Workbooks(DataBook).Worksheets(Datasht)
            EndRow = .Cells(Rows.Count, 1).End(xlUp).Row
            Endcolumn = .Cells(1, Columns.Count).End(xlToLeft).Column


            '開いたファイルのデータ部分をコピペする。(1回目だけデータ名もコピペする)
            If i = 0 Then

            '1回目だけ
            .Range(.Cells(1, 1), .Cells(EndRow, Endcolumn)).Copy Workbooks(NewBook).Wroksheets(NewSht).Rows(1)

            Else:

            '2回目以降
            .Range(.Cells(2, 1), .Cells(EndRow, Endcolumn)).Copy Workbooks(NewBook).Wroksheets(NewSht).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

            End If

            'データファイルを閉じる
            Workbooks(DataBook).Close SaveChanges:=False

        End With
        i = i + 1
    Loop

    '統合したファイルを名前を付けて保存
        Workbooks(NewBook).Worksheets(NewSht).Activate
        ActiveWorkbook.SaveAs Filename:= _
        OutputPath & Outputfile & ".xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False


    '閉じる
        ActiveWindow.Close
End Sub

試したこと

末尾のRows(1)の部分をCells(1,1)に指定したり試してみましたが、原因がわかりません。

補足情報(FW/ツールのバージョンなど)

.Range(.Cells(1, 1), .Cells(EndRow, Endcolumn)).Copy

の部分は、元ファイルでの動作になります。

Workbooks(NewBook).Wroksheets(NewSht).Rows(1)の部分の、
下記変数は、VBAで新規作成したブックを指定しています。
NewBook
NewSht

解決方法をご存知の方、ご教示のほどよろしくお願い致します。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • segavvy

    2019/11/24 02:04

    以下のようなコードだと思うのですが、手元の環境では動いてしまいました。何か差異はありそうでしょうか。環境はWindows 10、Excel 2016です。

    Sub test()
    With ActiveSheet
    EndRow = 1
    Endcolumn = 5
    NewBook = "Book2"
    NewSht = "Sheet1"

    .Range(.Cells(1, 1), .Cells(EndRow, Endcolumn)).Copy Workbooks(NewBook).Worksheets(NewSht).Rows(1)

    End With
    End Sub

    キャンセル

  • hatena19

    2019/11/24 10:41

    NewBook, NewSht の変数宣言、代入部分のコードも提示してください。
    おそらく、NewBook, NewSht がString型でなくオブジェクト型で宣言しているのが原因のような予感。

    キャンセル

  • tuckQ

    2019/11/24 11:57

    回答いただきありがとうございます。
    NewBook, NewSht がString型で指定しているのですが、うまくいっておりません。
    全体のコードを追記しましたので、ご確認いただければ幸いです。

    キャンセル

回答 3

checkベストアンサー

+2

Wroksheets -> worksheets
Rows(1) -> Cells(1,1)
ですかね。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/11/24 14:03 編集

    Rows()でも問題ない場合を検証してみましたら、私の環境ではcopyするセルの列数が5列以上の場合は、Rowsでも問題ありませんでした。
    4列未満の場合はXFD列までペーストされました。

    キャンセル

  • 2019/11/24 14:26

    検証ありがとうござます。そうなんですね。私も勉強になりました。
    ただ、わざわざRows(1)を使うメリットはないと思いますので、Cells(1,1) がいいですよね。

    キャンセル

  • 2019/11/24 14:52

    ご指摘のように、Wroksheets -> worksheetsが原因だったようで、修正したところ、正常に動作しました。初歩的なミスで恐縮です。ありがとうございました!

    キャンセル

+1

>下記変数は、VBAで新規作成したブックを指定しています。

その部分のコードも提示してください。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/11/24 11:58

    ご回答ありがとうございます。
    全体のコードを追記しましたので、ご確認いただければ幸いです。

    キャンセル

+1

実際のブックがないと検証は難しいので原因は分かりませんが、iruyasさんの回答のスペルミスが原因だと思われます。

下記の点を考慮して書き直してみました。(今後のコーティング時のご参考にしてください。)

  • Activeなオブジェクトを対象とすることを前提にしたコードは避ける。
    (読みづらいし、想定したものがアクティブでなかったりとバグの原因になりやすい)

  • 変数をString型にしてオブジェクト名でオブジェクトを参照せずに、変数をオブジェクト型にして直接参照したほうがシンプルになりコードが読みやすい。

Sub IntegPro()

    '変数宣言
    Dim MacroBook As Workbook
    Dim MacroSht As Worksheet
    Dim InputPath As String
    Dim OutputPath As String
    Dim Outputfile As String
    Dim InputFile As String
    Dim i As Integer
    Dim NewBook As Workbook
    Dim NewSht As Worksheet
    Dim DataBook As Workbook
    Dim DataSht As Worksheet
    Dim EndCell As Range

    '実行ファイルとシートの定義 Activeなのが前提のコードは避けるべき
    Set MacroBook = ThisWorkbook
    Set MacroSht = MacroBook("入力パスや出力パス、出力ファイルの定義してあるシート名")

    '新規ブックを作成し、それのブックとシートを定義する
    Set NewBook = Workbooks.Add
    Set NewSht = NewBook.Worksheets(1)

    '入力パスや出力パス、出力ファイルの定義
    With MacroSht
        InputPath = .Cells(2, 3).Value & "\"
        OutputPath = .Cells(3, 3).Value & "\"
        Outputfile = .Cells(4, 3).Value
    End With

    i = 0
    Do While MacroSht.Cells(7 + i, 3).Value <> ""

        'データファイルを開く
        Set DataBook = Workbooks.Open(InputPath & MacroSht.Cells(7 + i, 3))
        'データシートを定義する
        DataSht = DataBook.Worksheets(1)

        With DataSht
            'データファイルの最終セルを記憶する
            Set EndCell = .Range(.Cells(Rows.Count, 1).End(xlUp), _
                                 .Cells(1, Columns.Count).End(xlToLeft))

            '開いたファイルのデータ部分をコピペする。(1回目だけデータ名もコピペする)
            If i = 0 Then

                '1回目だけ
                .Range(.Cells(1, 1), EndCell).Copy NewSht.Cells(1, 1)

            Else

                '2回目以降
                .Range(.Cells(2, 1), EndCell).Copy _
                    Destination:=NewSht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

            End If

            'データファイルを閉じる
            DataBook.Close SaveChanges:=False

        End With
        i = i + 1
    Loop

    '統合したファイルを名前を付けて保存
    NewBook.SaveAs Filename:=OutputPath & Outputfile & ".xlsx", _
                   FileFormat:=xlOpenXMLWorkbook, _
                   CreateBackup:=False

    '閉じる
    NewBook.Close
End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/11/24 14:50

    全体的なコードの書き換えまでして頂きありがとうございました。アドバイス頂いた点、再学習して今後に活かせるようにしたいと思います!

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.49%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る