• 締切済み

Excelマクロについて

先日、OKWEBで教えてもらったマクロに手を加えて作ろうとしたのですが、エラーがでて動かなくなりました。 わかる方がいましたら教えてください。 よろしくおねがいします。 Sub 見積書() Application.ScreenUpdating = False '見積書(完成)シートを選択 Sheets("見積書(完成)").Select '行の高さを「15」にする。 Rows("6:67").Select Range("F6").Activate Selection.RowHeight = 15 'S列のS6:S56をコピーしてE6:E7に貼り付ける。 Range("S6:S56").Select Selection.Copy Range("E6:E7").Select ActiveSheet.Paste '5列目(工数)が「0」のとき該当する行の高さを「0」にする。 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 If Cells(i, 5).Value = "0" And Cells(i, 7).Value = "0" Then Rows(i).RowHeight = 0 End If Next '「E8:E55」の範囲を四捨五入する。 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 Range("E8:E55") = Application.Round(Range("E8:E55"), 0) '工数を四捨五入 Next 'C列の中に含まれる「小計」を検索しそこから6列目が「0」だったら行の高さを「0」にする。 Dim Rng As Range Const Retu = "C" For Each Rng In Range(Retu & "1", Range(Retu & "100").End(xlUp)) If Trim(Rng.Value) = "小　　　計" And _ Rng.Offset(, 6) = 0 Then Rng.EntireRow.Hidden = True End If Next Rng End Sub

  • taws
  • お礼率16% (46/279)

みんなの回答

  • periodayo
  • ベストアンサー率20% (64/315)
回答No.1

'S列のS6:S56をコピーしてE6:E7に貼り付ける。 Range("S6:S56").Select Selection.Copy Range("E6:E7").Select ActiveSheet.Paste これおかしくないですか？ コピー範囲と貼りつけ範囲が違っています。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • マクロ実行が遅い・・・

    皆さんにおしえてもらいながら下記のようなマクロを組みました。 しかし、マクロを実行すると計算中が長いのです。 もしこのマクロに原因があれば教えてください。 よろしくお願いします。 －－－－－－－－－－－－－－－－－－－－－－－－－－ Sub 見積書作成() Sheets("見積書").Select '見積書シートを選択 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 If Cells(i, 5).Value = "0" Then '工数が「0」のときは Rows(i).RowHeight = 0 '行高さ「0」 End If Next For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 Range("E8:E55") = Application.Round(Range("E8:E55"), 0) '工数を四捨五入 Next Dim Rng As Range Const Retu = "C" '<--- ここで「小計」の列を指定します。 For Each Rng In Range(Retu & "1", Range(Retu & "65536").End(xlUp)) If Trim(Rng.Value) = "小　　　計" And _ Rng.Offset(, 6) = 0 Then Rng.EntireRow.Hidden = True End If Next Rng End Sub

  • エクセル 2010 マクロ 検索

    http://okwave.jp/qa/q8562170.html 上記質問に追加です。 ※1 'D,E,F,G,H,I,K を検索してD,E,F,G,H,I に検索対象があった時 E,F,G,H,Iのいずれかだったら左横列の上に向かって (EならD　、FならE ・・・という具合に) 何か入力されているセルのM列の191000####をmsgboxで表示させたいです。 (画 F11セル(A-1)が検索ヒットした場合E9セル(R-01)を辿り、 その行のM列のセル(191000####)をmsgboxで表示 ※2 但し、検索結果がD列のデータだった時、その行のM列が191000####だった場合 M列の191000####をmsgboxで表示させたいです。 (画 D25セル(Y-1)対象の時) ※3 また、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合 (空白だったり191000####以外の場合) M列の一番上の191000####をmsgboxで 191000####&「これは例外です」と表示させたいです。 (画 D24セル (X-1)対象の時) 現在のコードは下記のとおりです。 Sheet1に Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address <> "$A$3" Then Exit Sub Call 検索 Range("A1:A2").Clear Range("A1").Activate End Sub 標準モジュールに Sub 検索() 　Dim Ws1 As Worksheet, Ws2 As Worksheet 　Dim strKey As Variant 　Dim s As String 　Dim c As Range, bln As Boolean 　Dim rng1 As Range 　Dim cnt As Long 　 　Set Ws1 = Sheet1 　Set Ws2 = Sheet2 　 　Ws1.Select 　 　With Ws2 　　strKey = Application.Transpose(.Range("A1").Resize(2).Value) 　　strKey = Join(strKey, "") 　End With 　 　If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub 　 　 　With Ws1 　　Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp)) 　　For Each c In rng1.Offset(, -10) 　　　 'D,E,F,G,H,I,Kを検索 　　　s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 8).Value & c.Offset(0, 10).Value & 　　　 　　　If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then 　　　　c.End(xlToRight).Activate c.Offset(0, 2).Value = Date 　　　　 　　　　c.Resize(1, 14).Interior.ColorIndex = 6 　　　　bln = True 　　　　Exit For 　　　End If 　　Next c 　　 　　If Not bln Then 　　　Ws2.Select 　　　MsgBox "リストに存在しません", vbExclamation, "NotFound" 　　Else '加える 　　　Call ReSearch(Ws1.Range("M2"), c.Row) 　　　'再設定 　　　Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp)) 　　　MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation 　　End If 　End With 　Application.Goto Ws2.Range("A1"), True End Sub Sub ReSearch(Rng As Range, j As Long) '最初のセル, 終わりの行数 Dim i As Long Dim Ws As Worksheet With Rng.Parent For i = j To Rng.Row Step -1 If CStr(.Cells(i, Rng.Column).Value) Like "191000####" Then MsgBox "指図番号 " & vbCrLf & CStr(.Cells(i, Rng.Column).Value) & " の部品です" Exit For End If Next i End With End Sub Function DoubleCountBlank(rng1 As Range, rng2 As Range) '横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2) 　Dim i As Long 　Dim cnt As Long 　For i = 1 To rng1.Rows.Count 　　If VarType(rng2.Cells(i, 1)) = vbDouble Then 　　　If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then 　　　　cnt = cnt + 1 　　　End If 　　End If 　Next i 　DoubleCountBlank = cnt End Function 宜しくお願い致します。

  • 複数のセルでの方法

    現在下記のようなマクロを組んであるのですが、これだと5列目が「0」のときの実行マクロです。 '5列目(工数)が「0」のとき該当する行の高さを「0」にする。 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 If Cells(i, 5).Value = "0" Then Rows(i).RowHeight = 0 End If Next 私はこれではなくて、5列目と7列目の同じ行にあるセルに「0」がはいっていたら行の高さを「0」にしたいのです。 そこで私は If Cells(i, 5).Value = "0" Then これを If Cells(i, 5).Value = "0"　And　Cells(i, 7).Value = "0" Then にしたところエラーが発生しました。 良い方法があればお教えください。 よろしくお願いします。

  • エクセルのマクロについて教えてください

    お世話になっております。 エクセルのマクロについて教えていただきたいのですが、 サンプルのファイルをこちらにアップしたのでよろしければご覧になってください。 http://kie.nu/yPV 質問したいことは、列Iに、各行の黄色いセルの数を表示させるマクロを作りたいのですが 途中まで何とかわかったのですがどうもうまくいきません。。 行11から各行にひとつずつ、黄色いセルが含まれていますが、その黄色いセルの中の数字を列Iに表示させたいです。行にデータがある限り、下までずっとです。 以下、途中までわかったマクロです。 Sub 黄セル値Copy() Const TgLeftUp = "A3" '<--対象範囲左上セル指定 Dim Rng As Range Dim Target As Range Set Target = Range(TgLeftUp, Cells(Rows.Count, _ Range(TgLeftUp).Column)) For Each Rng In Target.Resize(, 2) If Rng.Interior.ColorIndex = 6 Then If Rng.Column = Target.Column Then Rng.Offset(, 3).Value = Rng.Value Else Rng.Offset(, 2).Value = Rng.Value End If End If Next MsgBox "値 貼り付け完了。", vbInformation Set Target = Nothing End Sub でもこれを貼り付けてもうまくいきません。 正しいマクロを教えていただけないでしょうか？？ 宜しくお願いいたします。 ※いつも、私の質問に対してまるで回答になってないような、ふざけた言葉を書き込んでは消してる方が一名だけいらっしゃいます。確か、鳥の写真をマイページに載せてる方です。 都度違反報告はしていますが、質問の趣旨に反する回答をされてる方一名、絶対にやめてください。

  • excel2000マクロについて

    下記の様なマクロを書いていますが、別のマクロの記述の仕方で短縮に書くことはできないでしょうか。 Sub 承認捺印() Sheets("実行").Select If Range("E13").Value = "申請者" Then Sheets("ログイン").Select If Range("F11").Value = "a8012661" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 15").Copy Call 申請者捺印 End If If Range("F11").Value = "a6601456" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 16").Copy Call 申請者捺印 End If If Range("F11").Value = "t9907028" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 17").Copy Call 申請者捺印 End If If Range("F11").Value = "a7545410" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 18").Copy Call 申請者捺印 End If If Range("F11").Value = "t9806047" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 19").Copy Call 申請者捺印 End If If Range("F11").Value = "t0206030" Then Sheets("印章").Select ActiveSheet.Shapes("Picture 20").Copy Call 申請者捺印 End If 　end if end sub Sub 申請者捺印() Sheets("報告票").Select Range("m3").Select ActiveSheet.Paste Range("a1").Select End Sub

  • Excelマクロのことで教えて下さい

    初歩的なことですみません。 E列の値をF列に値を入れるために下記のマクロを組みました。 Sub test() Worksheets("Sheet1").Select Dim i As Long For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row Range("F2").Value = "=E2/1024/1024" Cells(i, 6).FillDown Range(Cells(2, 6), Cells(i, 6)).Copy Range("F2").PasteSpecial Paste:=xlValues Next i End Sub ところがF列に「値のみを貼り付け」をした時に、途中から同じ値のみがコピーされてしまい困っています。 （画像参照） うまく貼り付けることができるマクロをお教え下さい。 よろしくお願いいたします。

  • すべてのシートでマクロを実行したい

    以下のプログラムでは、選択したシートのみマクロが動作しています。ネット検索で見よう見まねで作ったため何がまちがっているのかわかりません。ご教示いただけるとありがたいです。 ・月の予定表で利用者が休みの日に斜線を引くマクロ ・入力ミスを防ぐためシート保護をしている Sub すべてのシート() Dim s As Worksheet For Each s In Worksheets s.Select Call 斜線 Next End Sub Sub 斜線() ActiveSheet.Unprotect Password:="1234" For i = 1 To Range("E10").End(xlDown).Row Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlNone If Range("E10").Value = 0 Then Exit Sub If Cells(i, "E").Value = "日" And Range("BP9").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "月" And Range("BP10").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "火" And Range("BP11").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "水" And Range("BP12").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "木" And Range("BP13").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "金" And Range("BP14").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "土" And Range("BP15").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "AY").Value = "祝日" And Range("BP16").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If Next i ActiveSheet.Protect Password:="1234" End Sub

  • マクロのソートについて

    A列:E列のセルデータがあって、空欄を省いて、コピペでるようにしたのでが、新たに、D列を最初にソート、後からB列・C列を連動させてソートしたいのですが、うまく処理できません。ご教授願えませんか。Sheets("ZZZZZZZ")のデータは１行おきのようなデータです。コピペまではできていますが、その後のソートについてお願いします。 Sub Macro1() Application.ScreenUpdating = False Dim Rng As Range Dim LastRow As Long '●ここをだけ"B2:B100"指定する For Each Rng In Sheets("ZZZZZZZ").Range("B2:B100") If Rng.Value <> "" Then LastRow = Sheets("QQQQQQQQ").Cells(Rows.Count, "B").End(xlUp).Row Sheets("QQQQQQQQ").Cells(LastRow + 1, "B").Resize(1, 3).Value = Rng.Resize(1, 3).Value End If Next Rng Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

  • エクセルVBAのRand()関数は？

    エクセルでマクロを書いているのですが Rand()関数を使用しようとするとエラーが起きてしまいます。。 アドインは全てインストールしているのですが、原因がわかりません。 知っている方しましたら、ご教授お願い致します。 ■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ Private Sub btnCreate_Click() 'ループ用の行数。 maxQuestion = 30 'ランダム用の最大値 maxRowCnt = ActiveSheet.UsedRange.Rows.Count For i = 1 To maxQuestion 'ランダムでコピーし貼り付け Sheets("Answer").Select rndm = Int(rand() * (maxRowCnt - 1) + 1) Sheets("Answer").Range("A" & rndm & ":" & "C" & rndm).Select Selection.Copy Sheets("Question").Select Range("A" & i).Select ActiveSheet.Paste delCol = Int(rand() * (2 - 1) + 1) If (delCol = 1) Then Sheets("Question").Cells(i, 1).Value = "" Else Sheets("Question").Cells(i, 2).Value = "" End If Next i End Sub

  • E列が空白のとき、その空白行を削除し、番号を振り直す

    windows7　Excel2003でマクロ勉強中です。 あるサイトにE列が空白のとき、その空白行を削除し、番号を振り直すという コードがありました。 自分で作った表（表の最上段の２行は項目名が入っています。）で　 実行すると「Rangeメソッドは失敗しました。Globalオブジェクト」と エラーが出ます。エラーはでますが、処理自体は正しく実行されます。 このエラーの原因と回避するにはどうしたらよろしいでしょうか。 Sub E列が空白のとき、その空白行を削除し、番号を振り直す() Dim i As Long, j As Long '行削除の処理 For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1 If Range("A" & i).Value <> "" And IsNumeric(Range("A" & i).Value) = True Then If Range("E" & i).Value = "" Then Rows(i).Delete End If End If Next '番号振りなおし処理 '’’Range("A" & Rows.Count).End(xlUp).Offset(1).Select For i = 0 To Range("A" & Rows.Count).End(xlUp).Row If Range("A" & i).Value = "番号" Then j = 1　・・・・・ここでエラー発生 If Range("A" & i).Value <> "" And IsNumeric(Range("A" & i).Value) = True Then Range("A" & i).Value = j j = j + 1 End If Next ActiveSheet.Protect End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する