• 締切済み

複数行コピー、貼り付け実行時エラー1004

ユーザー側が任意の場所を選択コピー し(2行毎) また 任意の位置に貼り付ける動作ですが 1回目のコピー、貼り付けは正常動作しますが 再度 コピー(任意の場所),貼り付け時に1004実行エラーが発生します。 下記はコードです。 どうかご教授お願いいたします。 Dim StartRow As Long, LastRow As Long, SRC As Long Sub コピー() If ActiveCell.Row < 76 Then Exit Sub StartRow = ActiveCell.Row: SRC = Selection.Rows.Count If (ActiveCell.Row Mod 2) = 0 Then StartRow = ActiveCell.Row If (Selection.Rows.Count Mod 2) = 0 Then LastRow = StartRow + Selection.Rows.Count - 1 Else LastRow = StartRow + Selection.Rows.Count End If Else StartRow = ActiveCell.Row - 1 If (Selection.Rows.Count Mod 2) = 0 Then LastRow = StartRow + Selection.Rows.Count + 1 Else LastRow = StartRow + Selection.Rows.Count End If End If ActiveSheet.Range(ActiveSheet.Cells(StartRow, 1), ActiveSheet.Cells(LastRow, 19)).Copy End Sub Sub 貼付け() If ActiveCell.Row >= 76 Or Application.ClipboardFormats(1) <> -1 Then ActiveSheet.Unprotect If (ActiveCell.Row Mod 2) = 0 Then StartRow = ActiveCell.Row Else StartRow = ActiveCell.Row - 1 End If ActiveSheet.Paste Destination:=Cells(StartRow, 1): Application.CutCopyMode = False ActiveSheet.Protect End If End Sub

みんなの回答

  • pcb39431
  • ベストアンサー率84% (16/19)
回答No.1

同じような質問が出ています。 そちらを参考にされてはどうですか？

参考URL：
http://ziddy.japan.zdnet.com/qa4762520.html
  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • マクロで複数の行をまとめて切り取りする方法

    Ｉの列のセルに「テスト」があったら、その行を切り取ってシート2に貼り付ける といった流れのコードが下記です。 Sub 切り取り() Dim i, LastRow As Long LastRow = Cells(Rows.Count, 9).End(xlUp).Row For i = 1 To LastRow If Cells(i, 9) = “テスト” Then Rows(i).Cut Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next i End Sub ●Ｉの列のセルに「テスト」と「課題」があったら、その行を切り取ってシート2に貼り付ける といったものをしたいのです。 1. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト,課題” Then 結果エラー 2. If Cells(i, 9) = “テスト” Then ↓ If Cells(i, 9) = “テスト&課題” Then 結果エラー 正常なコードを教えてくださいますか？ 宜しくお願いします。

  • マクロ　入力する文字に色を付けたい

    Sub CountUp(ByVal mCol1 As String, mCol2 As String) Dim LastRow1 As Long Dim LastRow2 As Long Dim mRow As Long With Sheets("プレーヤー") LastRow1 = .Cells(Rows.Count, mCol1).End(xlUp).Row LastRow2 = .Cells(Rows.Count, mCol2).End(xlUp).Row If LastRow1 > LastRow2 Then mRow = LastRow1 Else mRow = LastRow2 End If If LastRow1 = 1 Then LastRow1 = 2 End If .Cells(mRow + 1, mCol1).Value = .Cells(LastRow1, mCol1) + 1 End With End Sub このコードに文字の色の指定をしたいです Selection.Font.ColorIndex = 3を入れたら赤色文字で入力できるかなと思ったのですがうまくいきませんでした（エラーにはならないのですが、色が付かなかったです）

  • ExcelVBAで、選択範囲内で同じ値が入力されたセルを調べる

    選択範囲内（縦一列）で同じ値が入力されたセルの色を黄色にするプログラムを作りました。 Sub 選択範囲内で同じ値が入力されたセルを調べる_縦() Dim startrow As Byte Dim lasrow As Byte Dim i As Long Dim j As Byte Dim atai If TypeName(Selection) <> "Range" Then Exit Sub startrow = ActiveCell.Row '最初のセルの列番号を取得 lasrow = Selection.Rows(Selection.Rows.Count).Row '最終列番号を取得 '同じ値が入力されているセルを黄色にする For i = startrow To lasrow - 1 If ActiveSheet.Cells(i, ActiveCell.Column).Interior.ColorIndex = xlNone Then atai = ActiveSheet.Cells(i, ActiveCell.Column).Value For j = i + 1 To lasrow If atai = ActiveSheet.Cells(j, ActiveCell.Column).Value Then ActiveSheet.Cells(i, ActiveCell.Column).Interior.ColorIndex = 6 ActiveSheet.Cells(j, ActiveCell.Column).Interior.ColorIndex = 6 End If Next End If Next End Sub 但し、上記のプログラムでは選択範囲内に結合セルがあるとエラーになってしまいます。 どなたか、解決方法をご教授頂けませんでしょうか？ 宜しくお願い致しますm(._.)m

  • マクロ　行を切り取ってペーストでエラーになる

    J列に「0」と「#N/A」の行を切り取って集計対象外シートに貼り付けるといったコードです。 何故か途中でエラーになります。 どこが間違っておりますか？ 宜しくお願いします。 Dim LastRow As Long LastRow = Cells(Rows.Count, 10).End(xlUp).Row For i = 1 To LastRow If Cells(i, 10) = "0" Or Cells(i, 10) = "#N/A" Then Rows(i).Cut Sheets("集計対象外").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next i

  • Excel VBA: 複数行を選択したらエラーにしたい？

    お世話になります。 複数行にわたって選択しているときに実行するとエラーメッセージを出したいとします。現状では、 If Selection.Rows.Count <> 1 Then subMsgBox "You are selecting two or more rows" Exit Sub End If としていますが、これではドラッグで連続した行を選択している場合には正しくエラーになりますが、Ctrlクリックでポンポンと飛ばし飛ばしクリックしている場合はエラーになりません。 If Selection.Cells.Count <> 1 Then だと同じ行の複数個所を選んだ場合もエラーになってしまいます。 If Selection.Cells.EntireRow.Count <> 1 Then If Selection.Cells.EntireRow.Rows.Count <> 1 Then でもCtrl+クリックの場合にダメです。 どうしたらいいでしょうか。 よろしくお願いします。

  • フィルタでくくった状態でコピー貼り付け　(2)

    以前に、http://okwave.jp/qa/q6456460.html　で質問して解決したのですが 別のパターンで質問です。 以前は、Ｌ２から絶対だったのですが、今回は、セルが決まってません。 Ｌの1404にセルを持ってくるのに 一応 Sub 仕入先ブランク解除() Range("L1").Select Selection.End(xlDown).Select Selection.AutoFilter Field:=12, Criteria1:="=", Operator:=xlAnd Call 下に移動 ActiveCell.FormulaR1C1 = "=RC[-9]" Call 右に1マス移動 ActiveCell.FormulaR1C1 = "=RC[-9]" End Sub Sub 下に移動() ro = ActiveCell.Row co = ActiveCell.Column Range(Cells(ro + 1, co), Cells(ro + 1, co)).Select End Sub Sub 右に移動() ro = ActiveCell.Row co = ActiveCell.Column Range(Cells(ro + 1, co), Cells(ro + 1, co)).Select End Sub Sub 右に1マス移動() i = ActiveCell.Row j = ActiveCell.Column Cells(i + 0, j + 1).Select End Sub Sub メーカー名コピーあんど貼付() Dim r As Range With ActiveSheet Set r = .Range("L2", .Cells(.Rows.Count, "K").End(xlUp).Offset(, 1)) r.Item(1).Copy r If .FilterMode Then .ShowAllData End If r.Value = r.Value End With Set r = Nothing End Sub ってしました。 その後、関数のコピー貼り付けができません。（メーカー名コピーあんど貼付）の部分です わかる方がいましたらお願いします。

  • VBA 最終行を選んだシートにコピーする。

    VBAど初心者です。どうしても最終行のデータを選んだシートにコピーできません。 LastRow.Selectのところで、止まってしまいます。どのように行を設定していいのかさっぱりわかりません。どなたか、ご指導のほどよろしくお願いします。 Sub copy_last_line() Dim LastRow As Long Sheets("Sheet1").Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row LastRow.Select Selection.Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("A1").Select End Sub

  • 行コピーでエラー

    VBA初心者です。（というか、基本あまり使用しません。） 行の追加のロジックを初心者ながら作ったのですが、 保存する際に、エラーが通知されます。 どこが間違っているのでしょうか？ ちなみに、下記エラーは、解像度に関係しているようなのですが 写真やらそういったものは使用してません。 エラー内容： 　図が大きすぎます。入りきらない部分は切り捨てられます。 コード： Private Sub CommandButton2_Click() Dim myR As Variant myR = Application.InputBox("挿入する行数を入れてください") If IsNumeric(myR) Then Else MsgBox "計算できない値です。処理を終了します。" Exit Sub End If For i = 1 To myR Rows("1:1").Copy ←非表示の１行目をコピー。 Cells(ActiveCell.Row, 1).Select　←カーソル行にコピー。 Selection.Insert Shift:=xlDown　　 Selection.EntireRow.Hidden = False　←再表示する。 Next i Application.CutCopyMode = False End Sub

  • 再質問 エクセルの表の列の最下行から指定数の・・

    お世話になっております。 3日前にここでご回答いただいて解決したと思ったのですが、実シートで作業開始早々に不都合が出たので追加のHELPのお願いです。 各列の17行目以降に行方向にデータが入った表の下から30個のデータのMaxを求める関数のVBAを教わって早々に作業を開始したのですが、なぜか最下行を含まないVBAと、計算式の入った列では結果が「#VALUE!」となり、最下行を含むVBAの場合は、計算式の入った列の結果は「0」となってしまいます。 試しに別のシートで数値の列とその数値に定数をかけた列を作って試してみましたがうまく行きます。 また、対象のシートのセルの書式は数値になっています。 具体的な数式は =IF(F127="","",F127*5) というような単純な計算式で日付が入るような特殊な計算はやっていません。 項目 数値A 計算値A 数値B 数値B 数値C ------------------------------------------------------------------- 平均 1.1197 #VALUE! 46.6133 #VALUE! 44.6767 σ 0.0008 #VALUE! 2.5940 #VALUE! 0.2128 最小 1.117 0.000 42.100 0.000 44.300 最大 1.121 0.000 51.100 0.000 45.100 ＜最下行を含む場合＞ Function sfMax(Rng As Range, Optional bd) As Double Dim LastRow As Long Dim MyCol As Long Dim tgRng As Range Dim Border As Long Dim StartRow As Long Const DefBorder = 30 StartRow = 17 'データ開始行 If IsMissing(bd) Then Border = DefBorder '省略された場合の閾値 Else If ((bd = 0) Or (bd = "")) Then Border = DefBorder '省略された場合の閾値 Else Border = bd End If End If MyCol = Rng.Column LastRow = Cells(Rows.Count, MyCol).End(xlUp).Row If LastRow > StartRow + Border - 1 Then StartRow = LastRow - Border + 1 End If Set tgRng = Range(Cells(StartRow, MyCol), Cells(LastRow, MyCol)) sfMax = WorksheetFunction.Max(tgRng) End Function ＜最下行を副含まない場合＞ Function sfSTDEV(Rng As Range, Optional bd) As Double Dim LastRow As Long Dim MyCol As Long Dim tgRng As Range Dim Border As Long Dim StartRow As Long Const DefBorder = 30 StartRow = 17 'データ開始行 If IsMissing(bd) Then Border = DefBorder '省略された場合の閾値 Else If ((bd = 0) Or (bd = "")) Then Border = DefBorder '省略された場合の閾値 Else Border = bd End If End If MyCol = Rng.Column LastRow = Cells(Rows.Count, MyCol).End(xlUp).Row If LastRow > StartRow + Border - 1 Then LastRow = LastRow - 1 StartRow = LastRow - Border + 1 End If Set tgRng = Range(Cells(StartRow, MyCol), Cells(LastRow, MyCol)) sfSTDEV = WorksheetFunction.StDev(tgRng) End Function

  • 　VBA　表作成で内容を最下行で入力した場合　自動で次の行の作成を行いたい。

    VBAで質問です。　　Excel2003 最下行を検索し、そこの内容部分を入力された場合、1行あたらしく 式、罫線をコピーしたいのですがずっとループを起こしてしまいます。 直し方を教えていただきたいです。 ソース Private Sub Worksheet_Change(ByVal Target As Range) '------------------------------------ '変数の宣言 '------------------------------------ Dim naiyou As Object Dim bikou As Object Dim xline As Integer Dim yline As Integer Dim count As Integer Dim startrow As Integer Dim maxcolumn As Integer '------------------------------------ '内容＝D4の列検索 '------------------------------------ Set naiyou = ActiveSheet.Cells.Find("内容") xline = naiyou.Column '------------------------------------ '表示している最終行の検索 '------------------------------------ startrow = 4 count = Cells(startrow, xline).End(xlDown).Row '------------------------------------ '備考の＝I4列検索 '------------------------------------ Set bikou = ActiveSheet.Cells.Find("備考") yline = bikou.Column '------------------------------------ 'コピペ処理 '------------------------------------ If ActiveSheet.Cells(count, 4) <> "" Then Range(Cells(count + 1, 1), Cells(count + 1, yline)).Select Selection.Copy Range(Cells(count + 2, 1), Cells(count + 2, yline)).Select ActiveSheet.Paste Application.CutCopyMode = False Exit Sub Else: End If End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する