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

前へ 次へ
このQ&Aのポイント
  • マクロを使用して、入力された文字に色を付ける方法について質問します。
  • 現在のコードでは、文字の色を指定するためにSelection.Font.ColorIndex = 3を使用していますが、うまく機能しません。
  • エラーは表示されないものの、文字に色が付きません。どのように修正すれば良いでしょうか？
回答を見る
  • ベストアンサー

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

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を入れたら赤色文字で入力できるかなと思ったのですがうまくいきませんでした（エラーにはならないのですが、色が付かなかったです）

質問者が選んだベストアンサー

  • ベストアンサー
  • kkkkkm
  • ベストアンサー率65% (1615/2454)
回答No.1

最後に .Cells(mRow + 1, mCol1).Font.Color = vbRed として試してみてください。

その他の回答 (1)

  • kkkkkm
  • ベストアンサー率65% (1615/2454)
回答No.2

最後の文字だけ赤にして以前の文字は黒にしたい場合は .Cells(mRow + 1, mCol1).Font.Color = vbRed .Range(.Cells(2, mCol1), .Cells(mRow, mCol1)).Font.Color = vbBlack 条件つき書式でもできると思いますが重くなるかもしれませんので。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. Excel（エクセル）

関連するQ&A

  • 下記のマクロをもっと早くするには？

    下記のマクロは、 A列にあるURLがSSL化（https）されているかを調べるものです。 このマクロを動かすと、大体３秒に１つのURLを調べるくらいの早さです。 もっと早く調べられるようにするには、どのような記述にすればできるでしょうか？ また、エクセルの他の設定で、マクロを早くできたりしますか？ よろしくお願いいたします。 Sub SSL() Dim objHttp As Object Dim nURL As String Dim strURL As String Dim i As Long, f As String, l As String Dim Lastrow As Long, getLine As Long Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1") On Error GoTo ErrHandler 'A1から getLine = Cells(Rows.Count, 2).End(xlUp).Row Lastrow = Cells(Rows.Count, 1).End(xlUp).Row If getLine = Lastrow Then MsgBox "既に終わっているか、データがないです。", vbExclamation: Exit Sub If getLine < Lastrow And Cells(1, 2).Value <> "" Then getLine = getLine + 1 Else getLine = 1 '最初の行が1行目からの場合 End If For i = getLine To Lastrow strURL = LCase(Trim(Cells(i, 1).Value)) 'A列の登録URL strURL = Replace(strURL, "https:", "http:") If strURL Like "http*" Then objHttp.Open "GET", strURL, False objHttp.send DoEvents 'ESC割り込み可能にする With objHttp If .Status = 200 Then nURL = .Option(1) 'WinHttpRequestOption_URL f = Mid(strURL, 1, InStr(strURL, "://")) l = Mid(nURL, 1, InStr(nURL, "://")) If nURL = "" Then Cells(i, 2).Value = "no URL" ElseIf nURL <> "" Then If LCase(f) = LCase(l) Then Cells(i, 2).Value = "non SSL" Else Cells(i, 2).Value = "https" End If End If Else Cells(i, 2).Value = "Err:" & .Status End If End With End If Endline: nURL = "" strURL = "" Next i MsgBox "Finished" Exit Sub ErrHandler: If Err() <> 0 Then Cells(i, 2).Value = Err.Number 'マイナスになるのは外部エラー GoTo Endline End If End Sub

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

    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

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

    Ｉの列のセルに「テスト」があったら、その行を切り取ってシート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 結果エラー 正常なコードを教えてくださいますか？ 宜しくお願いします。

  • エクセル　検索コピーマクロ

    マクロで検索、抽出して別ファイルに保存したいのですが、 以下のようなマクロを教えてもらったのですが コピー先のセル位置を任意の位置に直したいのですが、 どうしてもわかりません どの部分をどう直せばよいのでしょうか？ Option Explicit Sub copyTodayData() Dim dateToday As String Dim tempDate As String Dim lastrow1 As Long Dim lastrow2 As Long Dim i As Long Dim fileA As String Dim anotherBook As String Dim anotherFilePath As String fileA = ThisWorkbook.Name anotherBook = "別のファイル.xls" anotherFilePath = "C:\Documents and Settings\日本太郎\デスクトップ\どこかのフォルダ" '問い合せダイアログの表示をOFFにします Application.DisplayAlerts = False 'ファイルを開く ChDir anotherFilePath Workbooks.Open Filename:=anotherFilePath & "\" & anotherBook '問い合せダイアログの表示をONに戻します Application.DisplayAlerts = True 'ウインドウの切替 Windows(fileA).Activate '今日の日付を取得 dateToday = Date 'データ最終行を取得 lastrow1 = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lastrow1 If Cells(i, 1) = dateToday Then 'Range(Cells(i, 1), Cells(i, 4)).Copy 'コピー Windows(anotherBook).Activate 'ウインドウの切替 lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ActiveSheet.Paste Windows(fileA).Activate 'ウインドウの切替 End If Next i MsgBox "実行しました" End Sub たぶん、lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ここらへんというのは、わかりますが、 どこをどう変えたらいいかわかりません

  • 二つのマクロで一気に処理したい

    以下のようなことができるのかお伺い致します。よろしくお願い致します。 　やりたいこと 　　※　前提として、sheet1にすでにA列に通し番号で奇数の数字が入っている。 　　　1.sheet1からsheet2へコピペーストする。しかし、A列からO列のすべてにデータがあった場合のみコピー貼り付けさせたい。 　　　　(前提で示したように、A列に通し番号で奇数の数字が入っていて、A列のみ数字があり、以外が空欄の行があるため) 　　　2.下記のコピー貼り付けのコードと重複削除のコードを合体させて、一つの処理で動かしたい。 Sub コピー貼り付けつけ()　　'コピー貼り付けつけのコード Dim lastRow As Long 'Sheet1のA3から最終行までをコピー With Sheets("sheet1") .Range("A3:O" & .Cells(Rows.Count, "A").End(xlUp).Row).Copy End With 'Sheet2のA列の最終行の次の行に貼付け Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Application.CutCopyMode = False End Sub Sub 重複データを一括削除する() ' Macro1 Macro Dim i As Long, lastRow As Long, myRng As Range LastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow - 1 If WorksheetFunction.CountIf(Range(Cells(i + 1, "O"), Cells(lastRow, "O")), Cells(i, "O")) > 0 Then If myRng Is Nothing Then Set myRng = Cells(i, "O") Else Set myRng = Union(myRng, Cells(i, "O")) End If End If Next i If Not myRng Is Nothing Then myRng.EntireRow.Delete End If End Sub

  • １つのPCで同じマクロを複数動かす

    下記のマクロは、 A列にあるURLがSSL化（https）されているかを調べるものです。 このマクロで、いろんなURLを調べる作業があります。 その作業を早く完了させるために、下記のマクロを同時に動かそうと思っています。 しかし、エクセルを使えるPCが１つしかありません。 エクセルを２つ起動して、調べるURLを分けて、 ２つのエクセルでマクロを同時に動かす。 これをやろうと思いましたが、かなりPCが重くなるし、 エクセルが度々フリーズしたみたいになります。 どうにか、１つのPCで下記のマクロを複数動かして、 いろんなURLを調べる作業を、早くに完了する方法はありますでしょうか？ エクセル2016です。 よろしくお願いいたします。 Sub SSL() Dim objHttp As Object Dim nURL As String Dim strURL As String Dim i As Long, f As String, l As String Dim Lastrow As Long, getLine As Long Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1") On Error GoTo ErrHandler 'A1から getLine = Cells(Rows.Count, 2).End(xlUp).Row Lastrow = Cells(Rows.Count, 1).End(xlUp).Row If getLine = Lastrow Then MsgBox "既に終わっているか、データがないです。", vbExclamation: Exit Sub If getLine < Lastrow And Cells(1, 2).Value <> "" Then getLine = getLine + 1 Else getLine = 1 '最初の行が1行目からの場合 End If For i = getLine To Lastrow strURL = LCase(Trim(Cells(i, 1).Value)) 'A列の登録URL strURL = Replace(strURL, "https:", "http:") If strURL Like "http*" Then objHttp.Open "GET", strURL, False objHttp.send DoEvents 'ESC割り込み可能にする With objHttp If .Status = 200 Then nURL = .Option(1) 'WinHttpRequestOption_URL f = Mid(strURL, 1, InStr(strURL, "://")) l = Mid(nURL, 1, InStr(nURL, "://")) If nURL = "" Then Cells(i, 2).Value = "no URL" ElseIf nURL <> "" Then If LCase(f) = LCase(l) Then Cells(i, 2).Value = "non SSL" Else Cells(i, 2).Value = "https" End If End If Else Cells(i, 2).Value = "Err:" & .Status End If End With End If Endline: nURL = "" strURL = "" Next i MsgBox "Finished" Exit Sub ErrHandler: If Err() <> 0 Then Cells(i, 2).Value = Err.Number 'マイナスになるのは外部エラー GoTo Endline End If End Sub

  • エクセルのマクロについて

    Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "ア") = 0 Then If InStr(.Cells(i, "D"), "ア(半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub このエクセルマクロはC列に「ア」があって、D列に「ア(半角)」の文字がない場合はメッセージというマクロなのですが、このマクロをア～ンまで同じ作業をしたいのですが、ひとまとめにマクロを組む事はできるのでしょうか？できる場合どのようにすれば良いでしょうか? 下記のようにして見たのですができませんでした。 Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "[ア-ン]") = 0 Then If InStr(.Cells(i, "D"), "[ア-ン](半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub

  • エクセル 同じ内容行削除マクロ　2

    シート1、シート2（基準）のB列を比較して同じ内容行を削除したいのですが、「栃木県3」と「＃栃木県3」を同じのもと考えて削除されてしまいます。 Sub 削除() 　　Dim wh1　　　　 As Worksheet 　　Dim wh2　　　　 As Worksheet 　　Dim f　　　　　 As Range 　　Dim wR　　　　　As Integer 　　Dim mR　　　　　As Long 　　Dim wStr　　　　As String 　　' 　　Set wh1 = Worksheets("Sheet1") 　　Set wh2 = Worksheets("Sheet2") 　　wR = 0 　　With wh1 　　　　mR = .Cells(Rows.Count, "A").End(xlUp).Row 　　　　For wR = mR To 1 Step -1 　　　　　　wStr = .Cells(wR, "B") 　　　　　　Set f = wh2.Range("B1:B" & wh2.Cells(Rows.Count, "B").End(xlUp).Row).Find(wStr) 　　　　　　If Not f Is Nothing Then 　　　　　　　　.Rows(wR).Delete 　　　　　　End If 　　　　Next 　　End With End Sub 解決策教えて下さい。

  • 検索　マクロ

    本を見ながら作ったのですが 検索してくれるのですが A列を検索してくれるのですが検索したいのは B列の4番目から下にあるだけ検索したいのですが どういじればいいのでしょうか？ Option Explicit Private lastRow As Long Private Index As Integer Private Sub UserForm_Activate() Dim i As Long lastRow = Worksheets("顧客情報").Cells(Rows.Count, 1).End(xlUp).Row + 1 If lastRow <= 3 Then MsgBox "データがありません。" Exit Sub End If For i = 3 To lastRow 名前リストボックス.AddItem Cells(i, 1) Next End Sub Private Sub 検索ボタン_Click() Dim searchName As String searchName = 検索名前テキストボックス.Text If searchName = "" Then MsgBox "検索する名前を入力してください。" Else Dim i As Long Dim no As Long For i = 0 To 名前リストボックス.ListCount - 1 If 名前リストボックス.List(i) = searchName Then no = i 名前リストボックス.ListIndex = no Exit For ElseIf i >= 名前リストボックス.ListCount - 1 Then MsgBox "該当なし。" Exit For End If Next Index = no + 3 Rows(Index).Select End If End Sub

  • 複数行コピー、貼り付け実行時エラー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

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する