Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


29120 / 76732 ←次へ | 前へ→

【52899】Re:Excel既存名簿から年齢別、所属別表を作る方法
発言  かみちゃん E-MAIL  - 07/12/8(土) 14:53 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>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
0 hits

【50719】Excel既存名簿から年齢別、所属別表を作る方法 marai 07/8/12(日) 22:41 質問
【50720】Re:Excel既存名簿から年齢別、所属別表を作... かみちゃん 07/8/12(日) 22:48 発言
【50724】Re:Excel既存名簿から年齢別、所属別表を作... marai 07/8/12(日) 23:38 発言
【50733】Re:Excel既存名簿から年齢別、所属別表を作... かみちゃん 07/8/13(月) 11:35 発言
【50777】Re:Excel既存名簿から年齢別、所属別表を作... marai 07/8/15(水) 6:19 お礼
【52496】Re:Excel既存名簿から年齢別、所属別表を作... marai 07/11/15(木) 19:28 質問
【52504】Re:Excel既存名簿から年齢別、所属別表を作... かみちゃん 07/11/15(木) 22:40 発言
【52519】Re:Excel既存名簿から年齢別、所属別表を作... marai 07/11/16(金) 16:11 発言
【52525】Re:Excel既存名簿から年齢別、所属別表を作... かみちゃん 07/11/17(土) 1:30 発言
【52600】Re:Excel既存名簿から年齢別、所属別表を作... marai 07/11/21(水) 5:10 発言
【52899】Re:Excel既存名簿から年齢別、所属別表を作... かみちゃん 07/12/8(土) 14:53 発言
【52902】Re:Excel既存名簿から年齢別、所属別表を作... marai 07/12/8(土) 21:16 お礼

29120 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free