Excel VBA質問箱 IV

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

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


5044 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【50719】Excel既存名簿から年齢別、所属別表を作...
質問  marai  - 07/8/12(日) 22:41 -

引用なし
パスワード
   当然、氏名、年齢、所属は、Excelの既存名簿に入っています。
ピボットテーブルでは、人数しか把握できませんでした。
人数ではなく、下記のような氏名表示にしたいのですが、
簡単にできる方法を教えてください。
Excelでは無理でしょうか?
以上 

例)
年齢   設計部  製造部  調達部  管理部
59才  山田太郎           田中信吾
 ・
 ・
32才       佐藤一郎 
          鈴木一郎
 ・
 ・
18才

【50720】Re:Excel既存名簿から年齢別、所属別表を...
発言  かみちゃん  - 07/8/12(日) 22:48 -

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

>簡単にできる方法を教えてください。
>Excelでは無理でしょうか?

簡単にできるかどうかは別として、「Excelでは」ということは他に何かアテが
あるのでしょうか?
Excelでもできると思います。

ただし、マクロでの処理を望まれるならば、処理開始前のシートイメージくらいは
提示できませんか?
あと、処理後のシートは同じシートなのか別シートなのかの条件提示はないのでしょうか?

また「当然」同一部署に同一年齢の人はいますよね?
そのときは、「佐藤一郎」「鈴木一郎」のような表示にしたいのですよね?
1人1行でいいのですか?

これらの情報が不足しているように思います。

【50724】Re:Excel既存名簿から年齢別、所属別表を...
発言  marai  - 07/8/12(日) 23:38 -

引用なし
パスワード
   早速ご返事ありがとうございます。
1.Excel以外、アテがないので、質問しました。
2.処理開始前のシートイメージは、次のとおりです。
 氏名   生年月日、年齢、所属、・・・・・・・
 田中一郎 1970/1/1 37  管理部 ・・・・・・
 データとしては150名分ほどです。
3.処理後のシートは、別シートを望みます。
4.同一部署に同一年齢の人が複数いる場合は、一人1行でもいいのですが、
 できれば、
 「佐藤一郎」
 「鈴木一郎」
 のように縦に並べて表示したいです。
 罫線は佐藤と鈴木の間には入れたくないです。
 手間がかかるようであれば一人1行でも十分です。

 例) |  設計部  |  製造部 | 
 −−−−−−−−−−−−−−−−−−−−
 32才|  佐藤一郎 |      |
    |  鈴木一郎 |      |
 −−−−−−−−−−−−−−−−−−−−
 33才|  山田太郎 |      |
 −−−−−−−−−−−−−−−−−−−−
 34才|       | 田中次郎 |


以上 情報が足りず申し訳ありませんでした。
よろしくおねがいします。

【50733】Re:Excel既存名簿から年齢別、所属別表を...
発言  かみちゃん  - 07/8/13(月) 11:35 -

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

>2.処理開始前のシートイメージは、次のとおりです。
> 氏名   生年月日、年齢、所属、・・・・・・・
> 田中一郎 1970/1/1 37  管理部 ・・・・・・
> データとしては150名分ほどです。
>3.処理後のシートは、別シートを望みます。
>4.同一部署に同一年齢の人が複数いる場合は、一人1行でもいいのですが、
> できれば、
> 「佐藤一郎」
> 「鈴木一郎」
> のように縦に並べて表示したいです。
> 罫線は佐藤と鈴木の間には入れたくないです。

Sheet1
   A     B    C   D   E
1 氏名   生年月日、年齢 所属
2 田中一郎 1970/1/1  37 管理部
3 佐藤一郎 1975/2/3  32 製造部
4 鈴木一郎 1975/3/4  32 製造部
5
というシートであった場合で、Sheet2に出力する場合であれば、
以下のようなコードでできます。

なお、同一部署で同一年齢の人は、セル内改行をすることで、同一
セルで表示するようにしています。
一人1セルにするには、面倒だったので。

あと、他にもっと速くてスマートな方法があるかもしれません。

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

【50777】Re:Excel既存名簿から年齢別、所属別表を...
お礼  marai  - 07/8/15(水) 6:19 -

引用なし
パスワード
   ▼かみちゃんへ :
おはようございます。
帰省していたため、返信がおそくなり申し訳ありません。
ご教示いただいた方法で実際にやってみたら、思い通りの表ができました。
マクロというものは使ったことがなかったので、覚えると、とても便利ですね。
正直言って、ご教示いただいたマクロの内容は、さっぱりわかりませんが、
そのままコピー&貼り付けをして、シート名だけ直したら、できちゃいました。
本当にありがとうございました。助かります。感謝、感謝!!
また、何か機会がありましたら、よろしくお願いいたします。
以上 みつ

>こんにちは。かみちゃん です。
>
>>2.処理開始前のシートイメージは、次のとおりです。
>> 氏名   生年月日、年齢、所属、・・・・・・・
>> 田中一郎 1970/1/1 37  管理部 ・・・・・・
>> データとしては150名分ほどです。
>>3.処理後のシートは、別シートを望みます。
>>4.同一部署に同一年齢の人が複数いる場合は、一人1行でもいいのですが、
>> できれば、
>> 「佐藤一郎」
>> 「鈴木一郎」
>> のように縦に並べて表示したいです。
>> 罫線は佐藤と鈴木の間には入れたくないです。
>
>Sheet1
>   A     B    C   D   E
>1 氏名   生年月日、年齢 所属
>2 田中一郎 1970/1/1  37 管理部
>3 佐藤一郎 1975/2/3  32 製造部
>4 鈴木一郎 1975/3/4  32 製造部
>5
>というシートであった場合で、Sheet2に出力する場合であれば、
>以下のようなコードでできます。
>
>なお、同一部署で同一年齢の人は、セル内改行をすることで、同一
>セルで表示するようにしています。
>一人1セルにするには、面倒だったので。
>
>あと、他にもっと速くてスマートな方法があるかもしれません。
>
>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

【52496】Re:Excel既存名簿から年齢別、所属別表を...
質問  marai  - 07/11/15(木) 19:28 -

引用なし
パスワード
   ▼かみちゃんへ
お久しぶりです。題記の件、以前質問して以来数ヶ月が経過しましたが、
表示を追加いたしたくご教示ください。
処理開始前のシートイメージは、以前と同じものに職位コードを追加。
氏名   生年月日、年齢、所属、 職位コード ・・・・・・・
田中一郎 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  管理部 ・・・・・・
>>> データとしては150名分ほどです。
>>>3.処理後のシートは、別シートを望みます。
>>>4.同一部署に同一年齢の人が複数いる場合は、一人1行でもいいのですが、
>>> できれば、
>>> 「佐藤一郎」
>>> 「鈴木一郎」
>>> のように縦に並べて表示したいです。
>>> 罫線は佐藤と鈴木の間には入れたくないです。
>>
>>Sheet1
>>   A     B    C   D   E
>>1 氏名   生年月日、年齢 所属
>>2 田中一郎 1970/1/1  37 管理部
>>3 佐藤一郎 1975/2/3  32 製造部
>>4 鈴木一郎 1975/3/4  32 製造部
>>5
>>というシートであった場合で、Sheet2に出力する場合であれば、
>>以下のようなコードでできます。
>>
>>なお、同一部署で同一年齢の人は、セル内改行をすることで、同一
>>セルで表示するようにしています。
>>一人1セルにするには、面倒だったので。
>>
>>あと、他にもっと速くてスマートな方法があるかもしれません。
>>
>>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

【52504】Re:Excel既存名簿から年齢別、所属別表を...
発言  かみちゃん E-MAIL  - 07/11/15(木) 22:40 -

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

>職位コードに応じ、氏名を次の色にしたい。
>00:黒、10:黒、20:ピンク、30:ブルー、40以上:こげ茶色
>なお、できれば氏名ではなく、その人のセルを色分けしたい

どういう結果を求めておられるのかわかりません。
以下のコードを追加することにより、Sheet1の職位コードの色分けはできます。
色分けのためには、Select Case 〜 を使います。

 Set LastCell = WS1.Cells(Rows.Count, 1).End(xlUp)

 WS1.Range("A2", LastCell).Font.ColorIndex = xlAutomatic
 For Each c In WS1.Range("A2", LastCell)
  Select Case c.Offset(, 4).Value
   Case "00"
    c.Font.ColorIndex = 1
   Case "10"
    c.Font.ColorIndex = 1
   Case "20"
    c.Font.ColorIndex = 7
   Case "30"
    c.Font.ColorIndex = 5
   Case Is >= "40"
    c.Font.ColorIndex = 53
  End Select
  lngRow = 0

【52519】Re:Excel既存名簿から年齢別、所属別表を...
発言  marai  - 07/11/16(金) 16:11 -

引用なし
パスワード
   sheet1ではなく、sheet1を基に作るsheet2(下記例参照)の氏名を色分けしたいのです。

例) |  設計部  |  製造部 | 
 −−−−−−−−−−−−−−−−−−−−
 32才|  佐藤一郎 |      |
    |  鈴木一郎 |      |
 −−−−−−−−−−−−−−−−−−−−
 33才|  山田太郎 |      |
 −−−−−−−−−−−−−−−−−−−−
 34才|       | 田中次郎 |


以上 情報が足りず申し訳ありませんでした。
よろしくおねがいします。

【52525】Re:Excel既存名簿から年齢別、所属別表を...
発言  かみちゃん  - 07/11/17(土) 1:30 -

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

>sheet1ではなく、sheet1を基に作るsheet2(下記例参照)の氏名を色分けしたい

この要件と
> 氏名ではなく、その人のセルを色分けしたい
のどちらですか?

【52600】Re:Excel既存名簿から年齢別、所属別表を...
発言  marai  - 07/11/21(水) 5:10 -

引用なし
パスワード
   お世話になります。maraiです。PCの調子が悪く返信が遅くなり申し訳ありません。
また、説明不足で申し訳ありません。最初から整理してみますと下記の通りです。
1.数ヶ月前は、既存名簿(*1)から年齢別・所属別一覧表(*2)を作る方法を貴殿よりご教示いただき、うまく作ることができました。その時の*1及び*2の様式等は過去ログの通りです。
2.今回は、*2の氏名を職位(部長以上、課長、係長、その他)に応じて色分けする機能を追加する方法をご教示頂きたいのです。
3.色分けしたいのは、*2の氏名のセルです。しかし、一つのセルが2名以上になると面倒になるのであれば、氏名を職位に応じて色分けしていただければ結構です。
以上、お手数をお掛けしますが、よろしくおねがいいたします。

【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

【52902】Re:Excel既存名簿から年齢別、所属別表を...
お礼  marai  - 07/12/8(土) 21:16 -

引用なし
パスワード
   ご検討くださり本当にありがとうございます。
早速月曜日会社でやってみたいと思います。
いつも、かみちゃんには助けてもらい感謝感謝です。

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