こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

Excelマクロ 全シートを対象に色付けするマクロ

「1枚目のシートのF行にあるデータを上から順番に選択し、同じデータがあれば黄色に塗る」
というマクロを作成しています。

ただし、全シートを検索対象にできなくて困っています。(ちなみにシート数は全20枚ほど)
下記のマクロのままではアクティブのシートしか検索できないため、全シートを検索対象にするためにはどうしたらいいでしょうか?

ご回答よろしくお願い致します。

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

With Application.ReplaceFormat.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Cells.Replace What:=Range("F" & i).Value, Replacement:=Range("F" & i).Value, LookAt:= _
xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=True
Application.CutCopyMode = False

End With

Next i

投稿日時 - 2010-11-15 15:00:44

QNo.6321123

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(9)

ANo.9

条件付き書式が使えなければ

Sub test3()
  Dim ws As Worksheet
  Dim r As Range
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim v
  
  With Sheets(1)
    .Range("F2", .Cells(.Rows.Count, 6).End(xlUp)).Name = "chkdata"
  End With
  Set ws = Sheets.Add(Sheets(1))
  For i = 3 To Sheets.Count
    Set r = Sheets(i).UsedRange
    With ws.Range(r.Address)
      .FormulaR1C1 = "=MATCH('" & Sheets(i).Name & "'!RC,chkdata,0)"
      v = .Value
      .ClearContents
    End With
    For j = 1 To UBound(v, 1)
      For k = 1 To UBound(v, 2)
        If IsNumeric(v(j, k)) Then
          r.Item(j, k).Interior.Color = 65535
        End If
      Next
    Next
  Next
  With Application
    .DisplayAlerts = False
    ws.Delete
    .DisplayAlerts = True
  End With
  
  Set r = Nothing
  Set ws = Nothing
End Sub

..こんなのでもいいかもしれませんね。HIT数が少ない場合は有利。



#ついでに..回答番号:No.7の訂正。
>#環境
>
>OS:WindowsXP pro sp3
>EXCEL:2003 11.8326.8324 sp3
>CPU:Intel Core2 1.86 GHz
>RAM:1.48 MB
RAM:1.48 GB...orz

#それに実は、質問コードを実行する前に[検索と置換]ダイアログで
#検索場所を「ブック」にするだけで良かったりもする...(オチ?

投稿日時 - 2010-11-26 22:59:54

ANo.8

>#結果
>
>初期サイズ   17762304
>test1     105.1563
>test1後サイズ 17762304
>test2     0.140625
>test2後サイズ 17763328
これは

Sub test()

  With wb
    With .Sheets(1).Range("F2").Resize(1000) '■
      .Formula = "=int(rand()*10000)"
      .Value = .Value
    End With

■箇所で設定した 検索値 100個の場合です。
With .Sheets(1).Range("F2").Resize(100)
検索値1,000個は無闇に試さないほうが良。

投稿日時 - 2010-11-26 14:39:02

ANo.7

'(続き)
'-----------------------------------------------------------
Sub test1()
  Dim i As Long
  Dim v, vi
  With wb.Sheets(1)
    v = .Range("F2", .Cells(.Rows.Count, 6).End(xlUp)).Value
  End With
  Application.ReplaceFormat.Interior.Color = 65535
  For i = 2 To wb.Sheets.Count
    With wb.Sheets(i).UsedRange
      For Each vi In v
        If Not IsEmpty(vi) Then
          .Replace What:=vi, _
               Replacement:=vi, _
               LookAt:=xlWhole, _
               SearchOrder:=xlByRows, _
               MatchCase:=False, _
               SearchFormat:=False, _
               ReplaceFormat:=True
        End If
      Next
    End With
  Next
End Sub
'-----------------------------------------------------------
Sub testreset()
  Dim i As Long
  For i = 2 To wb.Sheets.Count
    wb.Sheets(i).UsedRange.ClearFormats
  Next
End Sub
'-----------------------------------------------------------
Sub test2()
  Dim i As Long
  With wb.Worksheets(1)
    .Range("F2", .Cells(.Rows.Count, 6).End(xlUp)).Name = "chkdata"
  End With
  For i = 2 To wb.Sheets.Count
    With wb.Sheets(i).UsedRange.FormatConditions
      .Delete
      .Add(Type:=xlExpression, _
         Formula1:="=ISNUMBER(MATCH(RC,chkdata,0))") _
         .Interior.Color = 65535
    End With
  Next
End Sub
'-----------------------------------------------------------


#結果

初期サイズ   17762304
test1     105.1563
test1後サイズ 17762304
test2     0.140625
test2後サイズ 17763328


#検索値 1,000個

初期サイズ   17794560
test1     1055.844
test1後サイズ 17795072
test2     0.140625
test2後サイズ 17796096


#環境

OS:WindowsXP pro sp3
EXCEL:2003 11.8326.8324 sp3
CPU:Intel Core2 1.86 GHz
RAM:1.48 MB

投稿日時 - 2010-11-26 14:24:34

ANo.6

Option Explicit
Dim wb As Workbook
'-----------------------------------------------------------
Sub test()
  Dim bk As String
  Dim i As Long
  Dim t As Single

  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    i = .SheetsInNewWorkbook
    .SheetsInNewWorkbook = 20
    Set wb = Workbooks.Add
    .SheetsInNewWorkbook = i
    bk = .DefaultFilePath & "\tmp20101126.xls"
  End With
  With wb
    With .Sheets(1).Range("F2").Resize(1000)
      .Formula = "=int(rand()*10000)"
      .Value = .Value
    End With
    For i = 2 To 20
      With .Sheets(i).Range("A1").Resize(10000, 10)
        .Formula = "=int(rand()*10000)"
        .Value = .Value
      End With
    Next
    .SaveAs bk
    Debug.Print "初期サイズ", FileLen(bk)
    t = Timer
    Call test1
    Debug.Print "test1", Timer - t
    .Save
    Debug.Print "test1後サイズ", FileLen(bk)
    Call testreset
    t = Timer
    Call test2
    Debug.Print "test2", Timer - t
    .Save
    Debug.Print "test2後サイズ", FileLen(bk)
  End With
  With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
  End With
  Set wb = Nothing
End Sub
'-----------------------------------------------------------
'(続きあり)

投稿日時 - 2010-11-26 14:23:27

ANo.5

*********コード******************
Dim i As Long
Dim RowMax As Long
Dim TargetSheet As Worksheet
Dim SheetCount As Long

Application.ScreenUpdating = False '処理時間低減する為に、アプリケーションの再描画を止める

With Application.ReplaceFormat.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
End With


For Each TargetSheet In ActiveWorkbook.Sheets 'アクティブブックの全シートに対してループ開始
SheetCount = SheetCount + 1 '処理のカウント
RowMax = TargetSheet.Cells(Rows.Count, 1).End(xlUp).Row '現在取得中シートオブジェクトの最終Row位置を取得
For i = 2 To RowMax '検索ループ開始

TargetSheet.Cells.Replace _
What:=TargetSheet.Range("F" & i).Value, _
Replacement:=TargetSheet.Range("F" & i).Value, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=True

Application.CutCopyMode = False 'これは何もコピーしてないなら必要じゃないお
'処理の進捗が分ったほうがいいだろうから、これを追加しとくお
Application.StatusBar = "進捗:= " & Round((i / RowMax) * 100, 0) & "% " & _
SheetCount & "/" & ActiveWorkbook.Sheets.Count & "ページ"
Next i
Next

Application.StatusBar = False 'ステータスバーを元に戻す
Application.ScreenUpdating = True 'アプリケーションの再描画を再開するお

************************************

投稿日時 - 2010-11-25 16:25:36

ANo.4

なんとなく、意図がわかったけど・・・
とりあえず、全シート処理と追加要素を加えたコードを、ご参考に

*********コード******************
Dim i As Long
Dim RowMax As Long
Dim TargetSheet As Worksheet
Dim SheetCount As Long

Application.ScreenUpdating = False '処理時間低減する為に、アプリケーションの再描画を止める

With Application.ReplaceFormat.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
End With


For Each TargetSheet In ActiveWorkbook.Sheets 'アクティブブックの全シートに対してループ開始
SheetCount = SheetCount + 1 '処理のカウント
RowMax = TargetSheet.Cells(Rows.Count, 1).End(xlUp).Row '現在取得中シートオブジェクトの最終Row位置を取得
For i = 2 To RowMax '検索ループ開始

ActiveSheet.Cells.Replace _
What:=TargetSheet.Range("F" & i).Value, _
Replacement:=TargetSheet.Range("F" & i).Value, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=True

Application.CutCopyMode = False 'これは何もコピーしてないなら必要じゃないお
'処理の進捗が分ったほうがいいだろうから、これを追加しとくお
Application.StatusBar = "進捗:= " & Round((i / RowMax) * 100, 0) & "% " & _
SheetCount & "/" & ActiveWorkbook.Sheets.Count & "ページ"
Next i
Next

Application.StatusBar = False 'ステータスバーを元に戻す
Application.ScreenUpdating = True 'アプリケーションの再描画を再開するお

************************************

あと、画面更新を止めてしまえば、いうほど遅くはならないよ

むしろ、大量のセル数なら条件付書式設定の方が、重くなるよ
いちいち値を変えるたびに条件付書式ってのは判定を行うから
広範囲に設定するのは、推奨しないお
ファイルサイズもなぜか急激に肥大するしね

投稿日時 - 2010-11-25 16:08:04

ANo.3

>1枚目のシート..
が最左のWorksheetだとして、概ね

Dim i As Long
Dim v, vi

With Worksheets(1)
  v = .Range("F2", .Cells(.Rows.Count, 6).End(xlUp)).Value
End With

Application.ReplaceFormat.Interior.Color = 65535
For i = 2 To Worksheets.Count
  With Worksheets(i).UsedRange
    For Each vi In v
      If Not IsEmpty(vi) Then
        .Replace What:=vi, _
             Replacement:=vi, _
             LookAt:=xlWhole, _
             SearchOrder:=xlByRows, _
             MatchCase:=False, _
             SearchFormat:=False, _
             ReplaceFormat:=True
      End If
    Next
  End With
Next

こんな感じで出来ますが、F列のデータが多いとかなり重いです。

そのBookで他に[条件付き書式]を使ってなくて、
かつ[条件付き書式]での色付けで良い場合は下記のコードが効率良いです。

Dim i As Long

With Worksheets(1)
  .Range("F2", .Cells(.Rows.Count, 6).End(xlUp)).Name = "chkdata"
End With
For i = 2 To Worksheets.Count
  With Worksheets(i).UsedRange.FormatConditions
    .Delete
    .Add(Type:=xlExpression, Formula1:="=ISNUMBER(MATCH(RC,chkdata,0))") _
      .Interior.Color = 65535
  End With
Next

投稿日時 - 2010-11-15 21:16:26

それから

そのような操作は条件付き書式で対応可能と思われます。

投稿日時 - 2010-11-15 21:02:40

こんばんは。

直接の回答になるかどうかわかりませんが。

「Cells」という書き方はやめることですね。
やりたいならどのシートの「Cells」かをはっきり書くことです。
ActiveSheetに頼った書き方はやめることです。

このあたりはExcelのオブジェクトを理解しないとできないことだとは思いますが。

参考までに全シートを対称にする書き方をあげておきます。

Option Explicit

Sub test()
Dim WB As Workbook
Dim WS As Worksheet
Set WB = ThisWorkbook
For Each WS In WB.Worksheets
With WS.Cells
ここにやりたい処理を書く
End With
Next
End Sub

投稿日時 - 2010-11-15 20:52:52

あなたにオススメの質問