###前提・実現したいこと
次のイメージのようなエクセルで作った複数の見積書を、マクロでコピペして転記先のエクセルシートに一枚に情報をまとめるためのマクロを作成したいと考えています。
マクロを実行すると以下のエラーメッセージが発生しました。
###発生している問題・エラーメッセージ
実行時エラー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を使用しております。
どうぞよろしくお願いいたします。

回答1件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
退会済みユーザー
2017/12/15 01:57