[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数行を一行にまとめる方法』（あだすこ）
初めまして。
現在患者管理をExcelでやろうと思っています。
複数行で同じ患者の情報がシステムから出力されており、
これを一行にまとめたいのですがいい方法が思いつきません。
↓各セルに各個人の各時間と担当職員が一行づつあります。
room name time 担当
101 田中陽子 9:00 A
101 田中陽子 11:00 B
101 田中陽子 15:00 C
102 安倍太郎 10:00 D
102 安倍太郎 11:00 E
102 安倍太郎 12:00 F
上記の情報を下記のように患者名ごとに一行にまとめたいのですが、、
room name time 担当 time 担当 time 担当
101 田中陽子 9:00 A 11:00 B 15:00 C
102 安倍太郎 10:00 D 11:00 E 12:00 F
統合機能やVLOOKUPなどで試したのですが方向性が違うようで、
よい案をご教示いただけないでしょうか。よろしくお願いします。
＜ 使用 Excel：Excel2016mac、使用 OS：Windows10 ＞
A B C D
1 room name time 担当
2 101 田中陽子 9:00 A
3 101 田中陽子 11:00 B
4 101 田中陽子 15:00 C
5 102 安倍太郎 10:00 D
6 102 安倍太郎 11:00 E
7 102 安倍太郎 12:00 F
という前程です。
標準モジュールへ貼り付け
'**********************************************************
' 注意! 要、参照設定 Microsoft Scripting Runtime *
' Sheet1 が対象です。 *
' G1 以降の情報は消えます。 *
'**********************************************************
Option Explicit
Sub main()
Dim buf, i As Long, cnt As Long, r As Range
Dim mkey, j As Long, k As Long
Dim mdic As New Scripting.Dictionary
Worksheets("Sheet1").Activate
cnt = Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To cnt
mkey = Cells(i, 2)
If Not mdic.Exists(mkey) Then
mdic.Add mkey, ""
End If
Next i
i = 1
Range("g1").CurrentRegion.ClearContents
For Each buf In mdic
If i = 1 Then
Cells(i, 7) = Cells(i, 1)
Cells(i, 8) = Cells(i, 2)
Else
Cells(i, 8) = buf: j = 1: k = 2
For Each r In Range("b1:b" & cnt)
If r.Value = buf Then
Cells(1, 8).Offset(, j) = Cells(1, 3)
Cells(1, 8).Offset(, k) = Cells(1, 4)
Cells(i, 8).Offset(, -1) = r.Offset(, -1)
Cells(i, 8).Offset(, j) = r.Offset(, 1)
Cells(i, 8).Offset(, j).NumberFormatLocal = "h:mm"
Cells(i, 8).Offset(, k) = r.Offset(, 2)
j = j + 2
k = k + 2
End If
Next r
End If
i = i + 1
Next
Set mdic = Nothing
End Sub
バックアップをお取りの上お試し下さい。
参考まで。
<(_ _)>
ただ、同室、同名の場合は、その … ＾＾；
あと、空白、等
ご注意ください。
（隠居じーさん） 2017/12/09(土) 07:59
sheet2に転記するとして、こんな書き方もあるでしょう。
Sub test2()
Dim dic As Object
Dim ws1 As Worksheet, ws2 As Worksheet
Dim j As Long, k As Long
Dim r As Long
Dim s As String
Dim key As Variant
Set dic = CreateObject("Scripting.Dictionary")
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
' room + name をキーにして、連番（転記先の行番号）を作成
k = 1
For j = 2 To ws1.Range("A2").End(xlDown).Row
s = ws1.Cells(j, 1).Value & vbTab & ws1.Cells(j, 2).Value
If Not dic.Exists(s) Then
k = k + 1
dic(s) = k
End If
Next
' room ，name を転記
j = 1
For Each key In dic.keys
j = j + 1
ws2.Cells(j, 1).Resize(1, 2).Value = Split(key, vbTab)
Next
' time , 担当を転記
For j = 2 To ws1.Range("A2").End(xlDown).Row
s = ws1.Cells(j, 1).Value & vbTab & ws1.Cells(j, 2).Value
r = dic(s) ' 転記先行番号
ws1.Cells(j, 3).Resize(1, 2).Copy ws2.Cells(r, Columns.Count).End(xlToLeft).Offset(, 1)
Next
End Sub
ただし、こんな形式のほうが都合がいいんじゃないかと思ってみたり。 room name 9:00 10:00 11:00 12:00 13:00 14:00 15:00 16:00 17:00 18:00 101 田中陽子 A B C 102 安倍太郎 D E F
（Match関数を使って修正するのは容易でしょう。）
（γ） 2017/12/09(土) 09:12
Option Explicit
Sub test()
Dim 元データ As Worksheet
Dim 転記先 As Worksheet
Dim セル As Range
Dim 行 As Long, 列 As Long
Set 元データ = Worksheets("Sheet1")
Set 転記先 = Worksheets("Sheet2")
転記先.UsedRange.Offset(1).ClearContents
行 = 1
For Each セル In 元データ.Range("A2", 元データ.Range("A1").End(xlDown))
If セル.Value <> セル.Offset(-1).Value Then
行 = 行 + 1
列 = 1
セル.Resize(, 2).Copy 転記先.Cells(行, 列)
End If
列 = 列 + 2
セル.Offset(, 2).Resize(, 2).Copy 転記先.Cells(行, 列)
Next
End Sub
（マナ） 2017/12/09(土) 09:46
Sheet2!A2: =IFERROR(INDEX(Sheet1!$A$2:$B$7,SMALL(IF(MATCH(Sheet1!$B$2:$B$7,Sheet1!$B$2:$B$7,0)=ROW($A$1:$A$6),ROW($A$1:$A$6),""),ROW(A1)),COLUMN(A1)),"")
B2と下に必要数コピーします。
Sheet2!C2: =IFERROR(INDEX(Sheet1!$C$2:$D$7,SMALL(IF(Sheet1!$B$2:$B$7=$B2,ROW($A$1:$A$6),""),ROUNDUP(COLUMN(A1)/2,0)),MOD(COLUMN(A1)-1,2)+1),"")
右と下に必要数コピーします。
（メジロ） 2017/12/09(土) 09:50
Option Explicit
Sub test2()
Dim 元データ As Worksheet
Dim 転記先 As Worksheet
Dim セル As Range
Dim 行 As Long, 列 As Long
Set 元データ = Worksheets("Sheet1")
Set 転記先 = Worksheets("Sheet2")
転記先.UsedRange.Offset(1).ClearContents
行 = 1
For Each セル In 元データ.Range("B2", 元データ.Range("B1").End(xlDown))
If セル.Value <> セル.Offset(-1).Value Then
行 = 行 + 1
列 = 1
セル.Offset(, -1).Resize(, 2).Copy 転記先.Cells(行, 列)
End If
列 = 列 + 2
セル.Offset(, 1).Resize(, 2).Copy 転記先.Cells(行, 列)
Next
End Sub
（マナ） 2017/12/09(土) 10:17
こんばんわ。
私も数式で考えてみました。
Sheet2に結果を出すとして、1行目は見出しで、 A2 =Sheet1!A2 B2 =Sheet1!B2
A3 =IFERROR(INDEX(Sheet1!A:A,AGGREGATE(15,6,1/(Sheet1!$A$2:$A$1000>$A2)*ROW($A$2:$A$1000),1)),"") B列と下にフィルコピー
C2 =IF(OR($A2="",COUNTIF(Sheet1!$A:$A,$A2)<INT(COLUMN(B1)/2)),"",INDEX(Sheet1!$C:$D,COUNT($C$1:$L1)+INT(COLUMN(B1)/2)+1,MOD(COLUMN(B1),2)+1)) 必要数右と下にフィルコピー
上記式は同じ人のデータが最大5件、総データ数が1000行の999件までにしていますが、 同じ人の最大データ数は、COUNT($C$1:$L1)のLを変更すれば変わります。 例のように最大3件までならHで良いですし、10件とかならVにして下さい。
総データ数を変更したければ、A3の式の2か所の1000を変更して下さい。 C2の式は変更の必要はありません。
でも一番良いのはγさんが補足した、時間を予め見出し表示しておく方法と私も思います。
（sy） 2017/12/10(日) 00:36
ご返信有難うございます。
元データの項目が変化しても、（例：room name time 担当 担当区分）
ご教示いただきましたコードの中でResizeの箇所を変えることで応用もできました。
このようなケースはVBAのほうが楽で、、このようなケースはシート上の関数で・・
という判断が全然できていないのはVBA云々の以前にExcel自体の理解が不十分なようです。
＞ｙ様
＞ｓｙ様
時間を見出し表示にすればシンプルにでき、かつ見やすそうですね。
まだ試していないのですが、ご教示頂きました内容と合わせて書き出してみます。
（あだすこ） 2017/12/10(日) 03:36
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.