マクロで列の塗りつぶしを追加したい
- Excel VBAを使って、特定の条件下で列の塗りつぶしを設定するマクロを作成したいです。具体的には、セルに特定の値を入力した場合に、一定の範囲のセルをグレーで塗りつぶしたいです。
- 質問者は、現在のマクロでは特定の範囲のセルをグレーで塗りつぶしていますが、セルに式が入っている場合にも塗りつぶせるのかを確認したいと思っています。また、さらに他の範囲のセルもグレーで塗りつぶす方法も知りたいとしています。
- 質問者は、Excelのワークシートでセルのダブルクリックイベントを使用してマクロを実行しており、特定の値が入力された場合に特定のセルを更新しています。今回は、そのマクロに追加の塗りつぶし機能を実装したいと考えています。
- ベストアンサー
現マクロに列の塗りつぶし追加したい
マクロについては素人の私です。 図を参照いただきたいですが、J2にリストで「入金済み」と入力したとき下記のマクロでは F2 G2 I2 J2がグレーに塗りつぶしています。 但しE2には次のような式が入っています。 =IF(OR(B2="",C2=""),"",TEXT(B2,"yymmdd")&C2) このような式が入っていてもE2の塗りつぶしは可能でしょうか。可能ならば追加したいです。不可能ならE2は除きます。 もし可能ならばこれを B2 C2 D2 E2 もグレーでセルを塗りつぶすのを追加したいが下記のマクロをどうすればよろしいでしょうか。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim i As Long Dim r As Byte i = Sheets("入金記入").Range("B65536").End(xlUp).Row + 1 r = Target.Row If Target.Value = "入金済" Then With Sheets("入金記入") .Cells(i, 2).Value = Date .Cells(i, 3).Value = Cells(r, 3).Value .Cells(i, 4).Value = Cells(r, 4).Value End With End If End Sub ご指導の程、よろしく御願いします。
- dorasuke
- お礼率71% (459/642)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
＞図を参照いただきたいですが、J2にリストで「入金済み」と入力したとき下記のマクロでは F2 G2 I2 J2がグレーに塗りつぶしています お示しのマクロは、値の設定はしていますが、書式の設定はしていません、つまりグレーに塗りつぶす処理はしていません。 おそらく、F-Jには「条件付き書式」が設定されているのではないでしょうか？ セルF2を選択して「書式」ー「条件付き書式」で、設定されているかを確認してください。 もし、設定されていたら、次のようにしてB-E列にも適用します。 セルF2を起点としてB列の最終行までの範囲を選択します。 「書式」ー「条件付き書式」をクリックしてダイアログボックスが表示されるので、そのままOKをクリックします。 以上です。
関連するQ&A
- ２つのVBAを組み合わせる方法
お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？
- ベストアンサー
- Excel（エクセル）
- ＶＢＡ 別シートからコピー貼付け（複数列）
別シートからコピー貼付け（複数列）をしたいのですが，同一シートからのコピー貼付けはネットから以下のマクロでできました。 しかし，別シートsheet1からsheet2ヘコピーで修正しましたが，「アプリケーション定義またはオブジェクト定義のエラーです。」となります。どなたかご教授よろしくお願いします。 修正したマクロ Sub sampel() Dim i As Long For i = 2 To Range("E65536").End(xlUp).Row Step 2 Sheets("sheet2").Range(Cells(i + 1, 2), Cells(i + 1, 85)).Value = _ Sheets("sheet1").Range(Cells(i, 5), Cells(i, 88)).Value Next i End Sub 参考としたマクロ http://www.excel.studio-kazu.jp/kw/20041208152106.html Sub sampel() Dim i As Long For i = 2 To Range("E65536").End(xlUp).Row Step 2 Range(Cells(i + 1, 2), Cells(i + 1, 85)).Value = _ Range(Cells(i, 5), Cells(i, 88)).Value Next i End Sub
- ベストアンサー
- Windows 7
- Next,End Withのエラー
Sub 入力() If Sheets("入力").Range("D3").Value = "" Then MsgBox "客先名を入力して下さい" Else Dim K最終行 As Long Dim T最終行 As Long Dim i As Integer With Sheets("入力") For i = 3 To 12 If .Cells(i, "H").Value <> "" Then U最終行 = Sheets("注文書").Range("G65536").End(xlUp).Row + 1 If U最終行 = 461 Then MsgBox "注文書がいっぱいです" Exit Sub Else End If E最終行 = Sheets("営業確認").Range("G65536").End(xlUp).Row + 1 Sheets("営業確認").Range("k" & E最終行).Value = .Cells(i, "b").Value Sheets("営業確認").Range("b" & E最終行).Value = .Cells(i, "c").Value Sheets("営業確認").Range("c" & E最終行).Value = .Cells(i, "d").Value Sheets("営業確認").Range("d" & E最終行).Value = .Cells(i, "e").Value Sheets("営業確認").Range("g" & E最終行).Value = .Cells(i, "h").Value Sheets("営業確認").Range("f" & E最終行).Value = .Cells(i, "i").Value Sheets("営業確認").Range("i" & E最終行).Value = .Cells(i, "m").Value Sheets("営業確認").Range("h" & E最終行).Value = .Cells(i, "p").Value Else End If Select Case .Cells(i, "o").Value Case "北" K最終行 = Sheets("北").Range("h65536").End(xlUp).Row + 1 Sheets("北").Range("B" & K最終行).Value = .Cells(3, "C").Value Sheets("北").Range("c" & K最終行).Value = .Cells(3, "b").Value Case "中" T最終行 = Sheets("中").Range("H65536").End(xlUp).Row + 1 Sheets("中").Range("b" & T最終行).Value = .Cells(3, "c").Value Sheets("中").Range("c" & T最終行).Value = .Cells(3, "b").Value End Select Exit Sub Dim Dummy As Worksheet Dim SheetName As String Dim OTA As Long Dim GEN As Long Dim SheetName2 As String With Sheets("入力") '3行目～22行目まで For j = 3 To 22 SheetName = Sheets("入力").Range("D3").Value On Error Resume Next Set Dummy = Sheets(SheetName) SheetName2 = .Cells(i, 14).Value 'もしシートがあれば・・・ If Err.Number = 0 Then 'SheetName2は入力シートのN行 SheetName2 = .Cells(i, 14).Value OTA = Sheets(SheetName2).Range("B65536").End(xlUp).Row + 1 Sheets(SheetName2).Range("A7").Value = .Cells(3, "D").Value Sheets(SheetName2).Range("C3").Value = .Cells(3, "C").Value Sheets(SheetName2).Range("B" & OTA).Value = .Cells(i, "H").Value Sheets(SheetName2).Range("I" & OTA).Value = .Cells(i, "I").Value Sheets(SheetName2).Range("F" & OTA).Value = .Cells(i, "K").Value Sheets(SheetName2).Range("H" & OTA).Value = .Cells(i, "L").Value Sheets(SheetName2).Range("J" & OTA).Value = .Cells(i, "M").Value 'シートが無ければ・・・ Else GEN = Sheets("原紙").Range("B65536").End(xlUp).Row + 1 Sheets("原紙").Range("A7").Value = .Cells(3, "D").Value Sheets("原紙").Range("C3").Value = .Cells(3, "C").Value Sheets("原紙").Range("B" & GEN).Value = .Cells(i, "H").Value Sheets("原紙").Range("I" & GEN).Value = .Cells(i, "I").Value Sheets("原紙").Range("F" & GEN).Value = .Cells(i, "K").Value Sheets("原紙").Range("H" & GEN).Value = .Cells(i, "L").Value Sheets("原紙").Range("J" & GEN).Value = .Cells(i, "M").Value '原紙をコピーする Sheets("原紙").Copy BEFORE:=Sheets(1) 'シートの名前を市場コードにする Sheets(1).Name = SheetName Next End With Exit Sub On Error GoTo 0 Sheets("原紙").Select Range("C3:E3,A7,B16:B35,F16:F35,H16:J35").Select Range("H35").Activate Selection.ClearContents Sheets("入力").Select Sheets("入力").Range("D3,G3:J12,L3:M12").Value = "" Sheets("入力").Range("D3").Select Range("B3").Formula = "=IF(D3="""","""",VLOOKUP(D3,'\\Seika-sv01\支店共有\マーケティング用\[担当者リスト.xls]リスト形式'!$B:$D,3,FALSE))" MsgBox "入力が完了しました" End If End Sub 上記のようにマクロを組みましたがエラーが出てしまいます。
- 締切済み
- その他（プログラミング・開発）
- エクセル2003マクロの機能追加
Sub test() Dim 行1 As Long, 最終行 As Long, 行2 As Long Sheets("Sheet2").Cells.ClearContents Sheets("Sheet1").Activate 最終行 = Range("C65536").End(xlUp).Row 行2 = 1 For 行1 = 1 To 最終行 Sheets("Sheet2").Cells(行2, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value If Range("A" & 行1).Font.Bold Then Sheets("Sheet2").Range("A" & 行2) = Range("A" & 行1) & "-1" Sheets("Sheet2").Cells(行2 + 1, 1).Resize(1, 3) = Range(Cells(行1, 1), Cells(行1, 3)).Value Sheets("Sheet2").Range("A" & 行2 + 1) = Range("A" & 行1) & "-2" 行2 = 行2 + 1 End If If Range("A" & 行1) = "" Then 行2 = 行2 - 1 Sheets("Sheet2").Range("C" & 行2) = Sheets("Sheet2").Range("C" & 行2) + Range("C" & 行1) End If 行2 = 行2 + 1 Next 行1 End Sub 元データ AAAA5 9601 950 BBBB1 9660 150 ASAS9 9654 -50 AXCW5 9603 1375 以下の用にマクロで変換する機能を追加したいのです AAAA5 9601 950 BBBB1-1 9660 150 BBBB1-2 9660 150 ASAS9 9654 50 AXCW5 9603 1375 宜しくおねがいします。
- 締切済み
- Visual Basic
- エクセル マクロ 抽出
教えてください。 ○と記入されたセルを参照して、一つ上のセル・A列にある同じ行のセル・ 9行目にある同じ列のセルを抽出しようとしています。 下記の通り入力すると 行数＝値.Rowでエラーが出たしまいました。 試行錯誤頑張りましたが解決できそうにありませんのでお力を貸して頂けないでしょうか。 Sub 抽出() Dim i, 行数, 列数 As Long Dim 値 As Range i = 0 行数 = 値.Row 列数 = 値.Column For Each 値 In Sheets("sheet1").Range("C12:R171") If 値.Value = "○" Then i = i + 1 With Sheets("sheet2") .Cells(i, 3).Value = Sheets("sheet1").Cells(行数, 1).Value .Cells(i, 4).Value = Sheets("sheet1").Cells(9, 列数).Value .Cells(i, 5).Value = 値.Offset(-1, 0).Value End With End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- マクロについて教えてください。
マクロ初心者なのですが、下記にあるマクロコードは、ダブルクリックをすると指定した場所の数量が一つずつ減っていき、「0」になるときに「Yes」「No」と表示がでるのですが、これをダブルクリックではなく、一回押せば数量が一つ減り、「0」になるときは「Yes」「No」の表示がでずに、消えて下のものがつめるようにしたいのです。 そして、間違えた場合に一つ前に戻れる、「戻る」というボタンをつけたいのですが、分かる方がいましたらお力をかしていただけないでしょうか。宜しくお願いいたします。 'シートモジュールへ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Cells(Target.Row, 3).Value = 1 Then If MsgBox("xxx", vbYesNo) = vbYes Then Target.EntireRow.Delete Else Cells(Target.Row, 3).Value = Cells(Target.Row, 3).Value - 1 End If Cancel = True End Sub
- ベストアンサー
- Visual Basic
- エクセル、マクロにて月を指定して別シートに表示はできるのでしょうか？
エクセル、マクロにて月を指定して別シートに表示はできるのでしょうか？ 毎度毎度申し訳ありません。開始日の検索で、5月と打っただけ5月分だけ表示6月とうったら6月が出て来る方法なんてあるのでしょうか？ありましたら、下記のコードをどう直せいいか教えて頂けますでしょうか？宜しくお願い致します。 【作業内容：場所と月を検索、さらに要らない列を消し、別シートに表示】【検索月はC】 A B C D E F G H I J K 部署 No. 開始日 終了日 担当者 設備 刃名 枚数 内容 工数 備考 茨城 1 2010/5/7 2010/5/10 B緒 L型 K 16枚 研削 6.00 東和電気 東京 2 2010/6/7 2010/6/8 B緒 L型 K 16枚 研削 6.83 東和電気 茨城 3 2010/5/18 2010/5/19 B緒 L型 K 16枚 研削 1.50 東和電気 茨城 4 2010/5/16 2010/5/19 B緒 L型 K 16枚 研削 6.83 東和電気 茨城 5 2010/6/10 2010/6/10 B緒 L型 K 16枚 研削 6.83 東和電気 ↓ A B C D E F 部署 No. 開始日 担当者 内容 工数 茨城 1 2010/5/7 B緒 研削 6.00 茨城 3 2010/5/16 B緒 掃除 6.83 茨城 4 2010/5/18 B緒 出荷 1.50 【コード】 Sub 検索() Dim R As Long Dim Row2 As Long '●Sheet2書込み行 Sheets("集計表").Range("A5").CurrentRegion.Clear Sheets("集計表").Range("A5:F5").Value = Array("依頼部署", "依頼書No.", "研磨開始日", "担当者", "作業内容", "作業内容", "工数") Row2 = 5 For R = 2 To Sheets("日報").Cells(Rows.Count, "A").End(xlUp).Row If Sheets("日報").Cells(R, "A") = Sheets("集計表").Range("A2") And _ Sheets("日報").Cells(R, "C") >= Sheets("集計表").Range("B2") And _ Sheets("日報").Cells(R, "C") <= Sheets("集計表").Range("C2") Then Row2 = Row2 + 1 Sheets("集計表").Cells(Row2, "A").Value = Sheets("日報").Cells(R, "A").Value Sheets("集計表").Cells(Row2, "B").Value = Sheets("日報").Cells(R, "B").Value Sheets("集計表").Cells(Row2, "C").Value = Sheets("日報").Cells(R, "C").Value Sheets("集計表").Cells(Row2, "D").Value = Sheets("日報").Cells(R, "E").Value Sheets("集計表").Cells(Row2, "E").Value = Sheets("日報").Cells(R, "I").Value Sheets("集計表").Cells(Row2, "F").Value = Sheets("日報").Cells(R, "J").Value End If Next R '●結果の並べ替え If Row2 = 5 Then MsgBox "該当データなし！" Else Sheets("集計表").Range("A5:D" & Row2).Sort _ Key1:=Range("B6"), Order1:=xlAscending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, SortMethod:=xlPinYin Sheets("集計表").Select End Sub
- ベストアンサー
- その他MS Office製品
- すべてのシートでマクロを実行したい
以下のプログラムでは、選択したシートのみマクロが動作しています。ネット検索で見よう見まねで作ったため何がまちがっているのかわかりません。ご教示いただけるとありがたいです。 ・月の予定表で利用者が休みの日に斜線を引くマクロ ・入力ミスを防ぐためシート保護をしている 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
- ベストアンサー
- Excel（エクセル）
- Excel VBAのマクロについて
以下のようなマクロを作りました。 P4に開始番号P6に終わりの番号があるのですが、P4＝P6、つまり、一つだけのシートを作成する分には問題なく動きます。しかしP4に1、P6に5と範囲を増やすとエラーが出て動きません。どこをなおしたらよろしいでしょうか？ Option Explicit Sub 一括() Dim I As Worksheet Dim SheetName As String Dim Prompt As String Dim Col As Integer Dim Cell As Range Dim Row As Long Dim hani As Long For hani = Range("P4").Value To Range("P6").Value Set I = ActiveSheet SheetName = Cells(hani + 4, "K").Value & "(" & Cells(hani + 4, "B") & ")" Prompt = SheetName & "が存在します。" Sheets("基本シート").Copy After:=Sheets("基本シート") On Error GoTo 100 ActiveSheet.Name = SheetName On Error GoTo 0 Range("X3") = I.Cells(hani + 4, "B") Range("E8") = I.Cells(hani + 4, "C") Range("A13") = I.Cells(hani + 4, "D") For Col = 0 To 8 Step 4 Set Cell = I.Cells(hani + 4, "D").Offset(, Col) If Cell > 0 Then Prompt = "該当する日付がありません。" & Cell.Address On Error GoTo 100 Row = WorksheetFunction.Match(Cell, [A:A], 0) On Error GoTo 0 Cells(Row, "E") = I.Cells(hani + 4, "E").Offset(, Col) Cells(Row, "H") = I.Cells(hani + 4, "F").Offset(, Col) If Col < 8 Then Cells(Row, "Y") = I.Cells(hani + 4, "G").Offset(, Col) End If End If Next Col Next hani End 100 If Err <> 1004 Then Error Err End End If MsgBox Prompt, vbCritical Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True Sheets(1).Select End Sub
- ベストアンサー
- Visual Basic
- マクロの修正について
マクロの修正について教えてください！ ある文書を作成するのに必要なマクロのシートがあります。 抽出元の表を一部修正したため、現在のマクロでは正しく抽出されず、修正しています。 下記に詳細一部コピーしますが、これで抽出すると、同じデータが何度か繰り返し抽出され、重複してしまいます。 マクロの知識が全くなく、修正しているので、お力貸していただけると幸いです。 Application.ScreenUpdating = False '●●書 作成 Sheets("テンプレート").Select Sheets("テンプレート").Copy After:=Sheets(1) ActiveSheet.Name = "●●書" Sheets("まとめ").Select OutPutRow = 19 OutPutSheetCount = 1 'D列で最終行を確認 LastRow = Cells(1, 4).End(xlDown).Row For Row = 2 To LastRow datacount = Cells(Row, 27).Value For i = 1 To datacount If Cells(Row, 28 + (i - 1) * 7).Value <> "" Then '△データがあれば▲情報も出力 (1) = Cells(Row, 11).Value '代理店 (2) = Cells(Row, 26 + (i - 1) * 7).Value 'A (3) = Cells(Row, 5).Value 'B (4) = Cells(Row, 6).Value 'C (5) = Cells(Row, 25 + (i - 1) * 7).Value 'D (6) = Cells(Row, 18).Value 'E (7) = Cells(Row, 4).Value 'F (8) = Cells(Row, 10).Value 'G (9) = Cells(Row, 27 + (i - 1) * 7).Value 'H (10) = Cells(Row, 30 + (i - 1) * 7).Value 'I (11) = Cells(Row, 31 + (i - 1) * 7).Value 'J End If Sheets("●●書").Select Cells(OutPutRow, 2).Value = (11) Cells(OutPutRow + 1, 2).Value = (1) Cells(OutPutRow, 3).Value = (2) Cells(OutPutRow + 1, 3).Value = (3) Cells(OutPutRow, 4).Value = (5) Cells(OutPutRow + 1, 4).Value = (4) Cells(OutPutRow + 1, 5).Value = (6) Cells(OutPutRow, 6).Value = (7) Cells(OutPutRow + 1, 6).Value = (8) Cells(OutPutRow + 1, 7).Value = (9) Cells(OutPutRow + 1, 8).Value = (10) OutPutRow = OutPutRow + 2
- ベストアンサー
- オフィス系ソフト
お礼
早速ご回答いただき誠に有難うございました。 あなたのご指示通りさせていただいたら上手くゆきました。 小生はマクロを変更するばかりと思っていました。 このマクロは苦労して苦労して作成した物だから。 書式はすっかり忘れていました。 本当に有難うございました。 今後ともよろしく御願いします。