Excelデータの抽出 並べ替えについて

質問

Excelで、登録や契約日等を入れているのですが、一覧で見れるようで気無いか、苦心中です。
すいませんが、アドバイスをお願いします。

こんな事が出来ないかと思っています。
Excel5枚のシートを使います。

Sheet1　ココには、登録日・解約日を記していきます。
　　　A　　B　　　　　C　　　　　　　D　　　　　 E
　１　No.　氏名　登録・解約　　登録日　　 解約日　　
　2　　１　AB　　登録　　　　　1996/9/16
3 2 CD 登録　　　　 1996/9/17
4 3 EF 解約 1996/9/18 2010/11/27

Sheet2 には、契約日及び契約終了日を入れていきます。
　　　A　　B　　　　　C　　　　　　　D　　　　　
　１　No.　氏名　契約日　　 契約終了日　
　2　　１　AB　　2010/11/10 2011/11/9
3 2 CD 2010/11/11 2011/11/10
4 3 EF 2010/11/12 2011/11/11

Sheet3 には、証明書期限を入れていきます。
　　　A　　B　　　　　C　　　　　　　　　　　　
　１　No.　氏名　証期限
　2　　１　AB　　2010/11/21
3 2 CD 2010/11/22
4 3 EF 2010/11/23

この、上記3枚シートから、2枚のシートにデータを抽出並べ替えたいのです。

Sheet4
ここには、登録日順に顧客を表示し、横に、Sheet2,Sheet3にある、契約日・証期限を表示させたいのです。それも、契約日・証期限は、その各シートで、契約が更新される都度に、データが増えていくため、とうぜん、新旧が混在していますが、最新のデータを表示となります。
　　　A　　B　　　　　C　　　　　　D　　　　　　
　１　No.　氏名　契約日　　　　証期限
　2　　１　AB　　2010/11/19 2010/11/30
3 2 CD 2010/11/20 2010/12/1
4 3 GH 2010/11/22 2010/12/3
※Sheet1で解約になっている人は表示させません。

Sheet5では、Sheet1で解約になっている人を表示しないのは同様ですが、それ以上に、最新の契約日を基点として、顧客を羅列し、最新の証期限を表示したいのです。
　　　A　　B　　　　　C　　　　　　D　　　　　　
　１　No.　氏名　契約日　　　　証期限
　2　　１　QR　　2010/11/27 2010/12/8
3 2 OP 2010/11/26 2010/12/7
4 3 MN 2010/11/25 2010/12/6

大変ややこしい説明で申し訳ないのですが、
宜しくお願いします。

回答No.2

KURUMITO · ベストアンサー

作業列を作って対応します。
シート1のＦ2セルには次の式を入力して下方にオートフィルドラッグします。

=IF(OR(C2="",C2="解約"),"",D2)

シート2のＥ2セルには次の式を入力し、入力を確定する際にはＣｔｒlキーとＳｈｉｆｔキーを押しながらＥｎｔｅｒキーを押します。
その後にＦ2セルの式を下方にオートフィルドラッグします。

=IF(B2="","",IF(C2=MAX(IF(B:B=B2,C:C)),B2,""))

シート3のＤ2セルには次の式を入力し、入力を確定する際にはＣｔｒlキーとＳｈｉｆｔキーを押しながらＥｎｔｅｒキーを押します。

=IF(B2="","",IF(C2=MAX(IF(B:B=B2,C:C)),B2,""))

シート４のＡ2セルには次の式を入力し右横方向にオートフィルドラッグしたのちに下方にもオートフィルドラッグします。

=IF(ROW(A1)>COUNT(Sheet1!$F:$F),"",IF(COLUMN(A1)=1,ROW(A1),IF(COLUMN(A1)=2,IF(COUNTIF(Sheet1!$F:$F,SMALL(Sheet1!$F:$F,ROW(A1)))=0,"",INDEX(Sheet1!$B:$B,MATCH(SMALL(Sheet1!$F:$F,ROW(A1)),Sheet1!$F:$F,0))),IF(COLUMN(A1)=3,IF(COUNTIF(Sheet2!$E:$E,$B2)=0,"",INDEX(Sheet2!$C:$C,MATCH($B2,Sheet2!$E:$E,0))),IF(COLUMN(A1)=4,IF(COUNTIF(Sheet3!$D:$D,$B2)=0,"",INDEX(Sheet3!$C:$C,MATCH($B2,Sheet3!$D:$D,0))),"")))))

シート5のＡ2セルには次の式を入力し右横方向にオートフィルドラッグしたのちに下方にもオートフィルドラッグします。

=IF(ROW(A1)>MAX(Sheet4!$A:$A),"",IF(COLUMN(A1)=1,ROW(A1),IF(COLUMN(A1)=2,INDEX(Sheet4!$B:$B,MATCH(LARGE(Sheet4!$C:$C,ROW(A1)),Sheet4!$C:$C,0)),IF(COLUMN(A1)=3,INDEX(Sheet4!$C:$C,MATCH($B2,Sheet4!$B:$B,0)),IF(COLUMN(A1)=4,INDEX(Sheet4!$D:$D,MATCH($B2,Sheet4!$B:$B,0)),"")))))

なお、シート4や5のセルではセルに日付がシリアル数で表示されますのでセルの書式設定で日付にします。

お礼

有り難う御座います。
大変助かりました。読み取っていくと大変面白かったです。

回答No.5

merlionXX

ANo3です。
Sheet5は契約日は降順でしたね、修正です。

Sub test02()
Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")
Dim myN, myN2
With Sheets("Sheet1")
myN = .Range("B2", .Cells(Rows.Count, "C").End(xlUp)).Value
End With
For i = 1 To UBound(myN)
If Not myDic.Exists(myN(i, 1)) Then
If myN(i, 2) <> "解約" Then
myDic.Add myN(i, 1), ""
End If
Else '既出なら
If myN(i, 2) = "解約" Then
myDic.Remove (myN(i, 1))
End If
End If
Next i
With Sheets("Sheet4")
.Range("A2", .Cells(Rows.Count, "D")).ClearContents
.Range("B2").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.keys)
.Range("B2").Resize(myDic.Count, 1).Offset(, -1).Formula = "=ROW()-1"
.Range("B2").Resize(myDic.Count, 1).Offset(, -1).Copy
.Range("B2").Resize(myDic.Count, 1).Offset(, -1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
With Sheets("Sheet2")
myN2 = .Range("B2", .Cells(Rows.Count, "C").End(xlUp)).Value
End With
For i = 1 To UBound(myN2)
If myDic.Exists(myN2(i, 1)) Then
myDic(myN2(i, 1)) = myN2(i, 2)
End If
Next i
Sheets("Sheet4").Range("C2").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.items)
With Sheets("Sheet3")
myN3 = .Range("B2", .Cells(Rows.Count, "C").End(xlUp)).Value
End With
For i = 1 To UBound(myN3)
If myDic.Exists(myN3(i, 1)) Then
myDic(myN3(i, 1)) = myN3(i, 2)
End If
Next i
Sheets("Sheet4").Range("D2").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.items)
Sheets("Sheet4").Columns("A:D").Copy
With Sheets("Sheet5")
.Columns("A:D").PasteSpecial
Application.CutCopyMode = False
.Range("B2:D" & myDic.Count + 1).Sort Key1:=.Range("C2"), Order1:=xlDescending, Header:=xlNo, Orientation:=xlTopToBottom
End With
End Sub

お礼

有り難う御座います。
まずは関数でと考えていますが、この方法の方が、誤入力もなさそうなので、考えてみます。
助かりました。

回答No.4

某HN クロメート(Chromate)（@CoalTar）

考え方を理解してほしいので、同一シート内で説明するとする
F1セル0
F2セル 解約の除去のための作業列
=(C2<>"解約")+F1
下へオートフィル

E7セル 不要な計算の除去、契約日、または、過去に契約がある場合はその何日後かを出す
=IF(INDEX($C$2:$C$4,MATCH(B7,$B$2:$B$4,0))="解約","",
IF(ISNA(MATCH(B7,$B$6:B6,0)),C7,
MAX(0,C7-SUMIF($B$6:B6,B7,$E$6:E6))))
下へオートフィル

E15セルも同様、 不要な計算の除去、証期限

B21セル 解約者以外の氏名表示
=IF(ISNA(MATCH(A21,$F$2:$F$4,0)),"",INDEX($B$2:$B$4,MATCH(A21,$F$2:$F$4,0)))
オートフィル

C21 最新の契約日
=IF(B21="","",SUMIF($B$7:$B$12,B21,$E$7:$E$12))
D21 最新の証期限
=IF(B21="","",SUMIF($B$15:$B$18,B21,$E$15:$E$18))
C21:D21下へオートフィル

E21セル 同様の考え方で重複のない番号でSheet5への作業列、
=IF(B21="","",RANK(C21,$C$21:$C$23)+COUNTIF($C$20:C20,C21))
下へオートフィル

Sheet5は作成してません。添付図参照。

お礼

なるほどと思いました。

他の方も何人か触るので、どうしたものかなと思っていましたが、

この方法だと、万が一の時も修正しやすそうですね。

有り難うございます。

回答No.3

merlionXX

VBAでの方法です。
以下の手順をお試しください。

1.Altキー＋F11キー
2.画面上部のメニューバーから挿入、標準モジュールで、出てきた右側の白い広い部分に以下をコピペ
'***ここから下をコピペ***
Sub test01()
　　Dim myDic As Object
　　Set myDic = CreateObject("Scripting.Dictionary")
　　Dim myN, myN2
　　With Sheets("Sheet1")
　　　　myN = .Range("B2", .Cells(Rows.Count, "C").End(xlUp)).Value
　　End With
　　For i = 1 To UBound(myN)
　　　　If Not myDic.Exists(myN(i, 1)) Then
　　　　　　If myN(i, 2) <> "解約" Then
　　　　　　　　myDic.Add myN(i, 1), ""
　　　　　　End If
　　　　Else '既出なら
　　　　　　If myN(i, 2) = "解約" Then
　　　　　　　　myDic.Remove (myN(i, 1))
　　　　　　End If
　　　　End If
　　Next i
　　With Sheets("Sheet4")
　　　　.Range("A2", .Cells(Rows.Count, "D")).ClearContents
　　　　.Range("B2").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.keys)
　　　　.Range("B2").Resize(myDic.Count, 1).Offset(, -1).Formula = "=ROW()-1"
　　　　.Range("B2").Resize(myDic.Count, 1).Offset(, -1).Copy
　　　　.Range("B2").Resize(myDic.Count, 1).Offset(, -1).PasteSpecial xlPasteValues
　　　　Application.CutCopyMode = False
　　End With
　　With Sheets("Sheet2")
　　　　myN2 = .Range("B2", .Cells(Rows.Count, "C").End(xlUp)).Value
　　End With
　　For i = 1 To UBound(myN2)
　　　　If myDic.Exists(myN2(i, 1)) Then
　　　　　　myDic(myN2(i, 1)) = myN2(i, 2)
　　　　End If
　　Next i
　　Sheets("Sheet4").Range("C2").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.items)
　　With Sheets("Sheet3")
　　　　myN3 = .Range("B2", .Cells(Rows.Count, "C").End(xlUp)).Value
　　End With
　　For i = 1 To UBound(myN3)
　　　　If myDic.Exists(myN3(i, 1)) Then
　　　　　　myDic(myN3(i, 1)) = myN3(i, 2)
　　　　End If
　　Next i
　　Sheets("Sheet4").Range("D2").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.items)
　　Sheets("Sheet4").Columns("A:D").Copy
　　With Sheets("Sheet5")
　　　　.Columns("A:D").PasteSpecial
　　　　Application.CutCopyMode = False
　　　　.Range("B2:D" & myDic.Count + 1).Sort Key1:=.Range("C2"), Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom
　　End With
End Sub
'***ここより上までをコピペ***
3.Alt+F11キーでワークシートへ。
4. Alt+F8キー
5. test01を選択し実行ボタンをクリック

回答No.1

MackyNo1

例えば、Sheet4に以下のような数式を入力して下方向にオートフィルしてください。

B2セル（名前表示セル）

=INDEX(Sheet1!B:B,SMALL(INDEX((Sheet1!$E$2:$E$1000<>"")*10000+ROW($E$2:$E$1000),),ROW(B1)))&""

A1セル（連番表示セル）

=IF(B2="","",ROW(A1))

C２セル（最新の契約日表示セル）

=IF(B2="","",INDEX(Sheet2!C:C,MAX(INDEX((Sheet2!$B$2:$B$1000=B2)*ROW($C$2:$C$1000),))))

D2セル（最新の証期限入力セル）

=IF(B2="","",INDEX(Sheet3!C:C,MAX(INDEX((Sheet3!$B$2:$B$1000=B2)*ROW($C$2:$C$1000),))))

＞それ以上に、最新の契約日を基点として、顧客を羅列し、最新の証期限を表示したいのです。

Sheet5の表示内容の意味（Sheet4との違い）が良くわかりません。

表示データ数が多い場合は、数式で対応するとシートの動きが重くなるので、あまりお勧めできませんが、上記の数式を参考にして、ご自分で数式を組んでみて、もしうまくできないようでしたら、ご希望の集計方法を補足説明してください。