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

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

ただいまの
回答率

91.05%

  • VBA

    1368questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1161questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

実行時エラー1004について教えてください

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 224
退会済みユーザー

退会済みユーザー

前提・実現したいこと

次のイメージのようなエクセルで作った複数の見積書を、マクロでコピペして転記先のエクセルシートに一枚に情報をまとめるためのマクロを作成したいと考えています。
黄色のセルを転記先に情報をまとめる
マクロを実行すると以下のエラーメッセージが発生しました。

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

実行時エラー1004:この操作は結合したセルには行えません。

該当のソースコード

koumokuCell.Copy


が黄色くハイライトされています。
また、転記先となる一覧表は、下記の図の黄緑の2行のように転記したいですが、
その下の4-10行目に、
・4行目が空欄になってしまっている
・転記先の列は正しくペーストされているが、行は。5-10行目にばらばらに途中までコピペされてしまっている
のでそれも直したいです。
イメージ説明

全体のソースコード

Option Explicit

Sub 見積書DB化1()

    '前提条件
    '- 転記元のシートを前面に表示していること
    '- 転記先のシートがこのマクロが書かれいるブックであること


    '転記元のシートを取得
        'Excelで今アクティブなシート(Excel.ActiveWorkbookは省略可)
    Dim copyWs As Excel.Worksheet
    Set copyWs = Excel.ActiveWorkbook.ActiveSheet

    '転記先のシートを取得
        'マクロが書かれているブックの、アクティブなシート
    Dim pasteWs As Excel.Worksheet
    Set pasteWs = Excel.ThisWorkbook.ActiveSheet

    '入力する空白セルの指定
    Dim pasteCell As Excel.Range '元の処理の`InputRow`に相当する場所のセル
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "A").End(xlUp).Offset(1)

    '見積日を開いている転記元からコピーして転記先にペースト
    Dim mitumoriCell As Excel.Range
    Set mitumoriCell = copyWs.Range("A1")

    mitumoriCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

    '品名'を開いている転記元からコピーして転記先にペースト
        '見積日とやっていることはほぼ同じ
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "B").End(xlUp).Offset(1)

    Dim kenmeiCell As Excel.Range
    Set kenmeiCell = copyWs.Range("B12")

    kenmeiCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False
    'コピペは以下でも可
    'pasteCell.Value() = kenmeiCell.Value()


    '見積金額'を開いている転記元からコピーして転記先にペースト
        '見積日とやっていることはほぼ同じ
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "C").End(xlUp).Offset(1)

    Dim nonyuCell As Excel.Range
    Set nonyuCell = copyWs.Range("E12")

    nonyuCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

     '項目'を開いている転記元からコピーして転記先にペースト
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "D").End(xlUp).Offset(1)

    Dim koumokuCell As Excel.Range
    Set koumokuCell = copyWs.Range("A15, A19")

    koumokuCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

     'サイズ'を開いている転記元からコピーして転記先にペースト
    Set pasteCell = pasteWs.Cells(pasteWs.Rows.Count, "E").End(xlUp).Offset(1)

    Dim sizeCell As Excel.Range
    Set sizeCell = copyWs.Range("A16, A20")

    sizeCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

     '用紙'を開いている転記元からコピーして転記先にペースト
    Set paperCell = pasteWs.Cells(pasteWs.Rows.Count, "F").End(xlUp).Offset(1)

    Dim paperCell As Excel.Range
    Set paperCell = copyWs.Range("A17, A21")

    paperCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

     '印刷'を開いている転記元からコピーして転記先にペースト
    Set insatsuCell = pasteWs.Cells(pasteWs.Rows.Count, "G").End(xlUp).Offset(1)

    Dim insatsuCell As Excel.Range
    Set insatsuCell = copyWs.Range("A18, A22")

    insatsuCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

     '内訳'を開いている転記元からコピーして転記先にペースト
    Set uchiwakeCell = pasteWs.Cells(pasteWs.Rows.Count, "H").End(xlUp).Offset(1)

    Dim uchiwakeCell As Excel.Range
    Set uchiwakeCell = copyWs.Range("A27:A28")

    uchiwakeCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

     '数量'を開いている転記元からコピーして転記先にペースト
    Set suryoCell = pasteWs.Cells(pasteWs.Rows.Count, "I").End(xlUp).Offset(1)

    Dim suryoCell As Excel.Range
    Set suryoCell = copyWs.Range("C27:C28")

    suryoCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

     '単価'を開いている転記元からコピーして転記先にペースト
    Set tankaCell = pasteWs.Cells(pasteWs.Rows.Count, "J").End(xlUp).Offset(1)

    Dim tankaCell As Excel.Range
    Set tankaCell = copyWs.Range("D27:D28")

    tankaCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False

     '金額'を開いている転記元からコピーして転記先にペースト
    Set kingakuCell = pasteWs.Cells(pasteWs.Rows.Count, "K").End(xlUp).Offset(1)

    Dim kingakuCell As Excel.Range
    Set kingakuCell = copyWs.Range("G27:G28")

    kingakuCell.Copy
    pasteCell.PasteSpecial Paste:=xlPasteValues, _
                           Operation:=xlNone, _
                           SkipBlanks:=False, _
                           Transpose:=False


    End With 'copyWs


End Sub

試したことは、フォルダを転記先と転記元おなじ階層のフォルダに格納しなおしました。

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

Excel2016を使用しております。
どうぞよろしくお願いいたします。

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

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

回答 1

checkベストアンサー

0

A15セルとB15セル、A19セルとB19セルは結合されていませんか?
結合セルをコピーしようとするとご質問のエラーになります。
結合セルは「MergeArea」で扱えますので試してみてください。
具体的には

Set koumokuCell = copyWs.Range("A15, A19")

Set koumokuCell = Union(copyWs.Range("A15").MergeArea, copyWs.Range("A19").MergeArea)

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2017/12/15 10:57

    早速のご回答ありがとうございます!
    無事、なおって実行できました!!
    結合セルについてよくわかってなかったので、わかりやすいアドバイス大変助かりました。
    ありがとうございました!!

    キャンセル

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

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

関連した質問

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

  • VBA

    1368questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    1161questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。