| |
▼かみちゃんへ
お久しぶりです。題記の件、以前質問して以来数ヶ月が経過しましたが、
表示を追加いたしたくご教示ください。
処理開始前のシートイメージは、以前と同じものに職位コードを追加。
氏名 生年月日、年齢、所属、 職位コード ・・・・・・・
田中一郎 1970/1/1 37 管理部 10 ・・・・・・
佐藤一郎 1975/2/3 32 製造部 20
鈴木一郎 1975/3/4 32 製造部 30
＜ご教示いただきたい内容＞
職位コードに応じ、氏名を次の色にしたい。
00：黒、10：黒、20：ピンク、30：ブルー、40以上：こげ茶色
なお、できれば氏名ではなく、その人のセルを色分けしたいですが、手間がかかるのであれば氏名の色分けで結構です。
▼marai さん：
>▼かみちゃんへ ：
>おはようございます。
>帰省していたため、返信がおそくなり申し訳ありません。
>ご教示いただいた方法で実際にやってみたら、思い通りの表ができました。
>マクロというものは使ったことがなかったので、覚えると、とても便利ですね。
>正直言って、ご教示いただいたマクロの内容は、さっぱりわかりませんが、
>そのままコピー＆貼り付けをして、シート名だけ直したら、できちゃいました。
>本当にありがとうございました。助かります。感謝、感謝！！
>また、何か機会がありましたら、よろしくお願いいたします。
>以上 みつ
>
>>こんにちは。かみちゃん です。
>>
>>>2.処理開始前のシートイメージは、次のとおりです。
>>> 氏名 生年月日、年齢、所属、・・・・・・・
>>> 田中一郎 1970/1/1 37 管理部 ・・・・・・
>>> データとしては１５０名分ほどです。
>>>3.処理後のシートは、別シートを望みます。
>>>4.同一部署に同一年齢の人が複数いる場合は、一人１行でもいいのですが、
>>> できれば、
>>> 「佐藤一郎」
>>> 「鈴木一郎」
>>> のように縦に並べて表示したいです。
>>> 罫線は佐藤と鈴木の間には入れたくないです。
>>
>>Sheet1
>> A B C D E
>>1 氏名 生年月日、年齢 所属
>>2 田中一郎 1970/1/1 37 管理部
>>3 佐藤一郎 1975/2/3 32 製造部
>>4 鈴木一郎 1975/3/4 32 製造部
>>5
>>というシートであった場合で、Sheet2に出力する場合であれば、
>>以下のようなコードでできます。
>>
>>なお、同一部署で同一年齢の人は、セル内改行をすることで、同一
>>セルで表示するようにしています。
>>一人１セルにするには、面倒だったので。
>>
>>あと、他にもっと速くてスマートな方法があるかもしれません。
>>
>>Sub Sample()
>> Dim WS1 As Worksheet
>> Dim WS2 As Worksheet
>> Dim LastCell As Range
>> Dim c As Range
>> Dim lngRow As Long
>> Dim intCol 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 = c.Value
>> Else
>> .Value = .Value & vbCrLf & c.Value
>> End If
>> End With
>> Next
>>End Sub
|
|
marai
- 07/11/15(木) 19:28 -
