| |
こんにちは。かみちゃん です。
>2.今回は、*2の氏名を職位(部長以上、課長、係長、その他)に応じて色分けする機能を追加する方法をご教示頂きたいのです。
>3.色分けしたいのは、*2の氏名のセルです。
すっかり遅くなり、未解決のようですので、検討してみました。
今まで提示したマクロに、色わけ部分を「マクロの記録」で記録したものを
加えると以下のような感じでできると思います。
Sub Sample1()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim LastCell As Range
Dim c As Range
Dim lngRow As Long
Dim intCol As Integer
Dim intFontColorIndex As Integer
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
Set LastCell = WS1.Cells(Rows.Count, 1).End(xlUp)
For Each c In WS1.Range("A2", LastCell)
lngRow = 0
On Error Resume Next
lngRow = WorksheetFunction.Match(c.Offset(, 2).Value, WS2.Columns("A"), 0)
On Error GoTo 0
If lngRow = 0 Then
lngRow = WS2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
WS2.Cells(lngRow, "A").Value = c.Offset(, 2).Value
End If
intCol = 0
On Error Resume Next
intCol = WorksheetFunction.Match(c.Offset(, 3).Value, WS2.Rows("1"), 0)
On Error GoTo 0
If intCol = 0 Then
intCol = WS2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Column
WS2.Cells(1, intCol).Value = c.Offset(, 3).Value
End If
With WS2.Cells(lngRow, intCol)
If .Value <> "" Then
.Value = .Value & vbCrLf
End If
.Value = .Value & c.Value
Debug.Print .Address & "--" & Len(.Value) & "--" & Len(c.Value)
'00：黒、10：黒、20：ピンク、30：ブルー、40以上：こげ茶色
intFontColorIndex = 0
Select Case c.Offset(, 4).Value
Case 0, 10
intFontColorIndex = 1
Case 20
intFontColorIndex = 7
Case 30
intFontColorIndex = 5
Case Is >= 40
intFontColorIndex = 53
End Select
With .Characters(Start:=Len(c.Value) - Len(.Value), Length:=Len(c.Value)).Font
If intFontColorIndex > 0 Then
.ColorIndex = intFontColorIndex
Else
.ColorIndex = xlAutomatic
End If
End With
End With
Next
End Sub
|
|
かみちゃん
- 07/12/8(土) 14:53 -
