| |
こんにちは。かみちゃん です。
>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
|
|
かみちゃん
- 07/8/13(月) 11:35 -
