[[20161126004007]]　『A列が同じもののうち、B列の数値が多いものと少な』（tororo）　ページの最後に飛ぶ

『A列が同じもののうち、B列の数値が多いものと少ないものを取り出したい』（tororo）

はじめまして。
　
下のようなシートがあります。
このシートのA列が同じもののうち、B列の一番数値の多いものと少ないものを別列に抽出したいのですが良い方法を教えて貰えないでしょうか。

事例を作ってみました。
下のようなAB列を、CDE列に抽出したいと思ってます。

 A列	B列		       （C列）	（D列）	      （E列）
 ABC氏	20161103		ABC氏	20161103	20160501
 ABC氏	20161102		XYZ氏	20151102	20151102
 ABC氏	20160501		HJK氏	20160101	20150101
 ABC氏	20161102		TYU氏	20161125	20131212
 XYZ氏	20151102				
 HJK氏	20150101				
 HJK氏	20160101				
 TYU氏	20131212				
 TYU氏	20131212				
 TYU氏	20161125

宜しくお願い致します。

＜使用 Excel：Excel2016、使用 OS：Windows7 ＞

ども＾＾
ピボットテーブルが便利そうです＾＾

http://haku1569.seesaa.net/article/403458311.html

（まっつわん） 2016/11/26(土) 08:54

 数式でやるとすれば。（データが１行目からとして）

 C1 : =A1
 C2 : =IFERROR(VLOOKUP("*",IF(COUNTIF(C$1:C1,A$1:A$100)=0,A$1:A$100),1,FALSE),"")
     これを　Ctrl/SHift/Enter で入力し、下にフィルコピー。（この式の意味は、ほんとはよくわかっていません）

 D1 : =IF(C1="","",MAX(IF(A$1:A$100=C1,B$1:B$100)))  Ctrl/Shift/Enter で入力
 E1 : =IF(C1="","",MIN(IF(A$1:A$100=C1,B$1:B$100)))  Ctrl/Shift/Enter で入力

 D1:E1 を下にフィルコピー。

（β） 2016/11/26(土) 09:20

わたしがいつも奨めているのは「統合」です。
機能が少ないので、操作を簡単に覚えられます。

 １）C列を選んで「データ」ー「統合」
 　　・集計の方法：最小値に変更
 　　・統合先：集計するデータ範囲（またはA列B列全体）を選択
 　　・統合の基準：左端列にチェック
 ２）D列を選んで列挿入
 ３）再度、C列を選んで「データ」ー「統合」
 　　・集計の方法：最大値に変更

慣れていれば、1分ほどの操作です。

（マナ） 2016/11/26(土) 10:49

皆さん有難うございます。
βさんの方法を使わせてもらおうと思います。

Ctrl/SHift/Enter で入力し、下にフィルコピー。（この式の意味は、ほんとはよくわかっていません

が若干の不安ではありますが・・・。
（tororo） 2016/11/26(土) 16:37

Sub main()'ご参考

    Dim rg1 As Range, rg2 As Range, rg3 As Range, rg4 As Range
    Range("C:D").ClearContents
    For Each rg1 In Range("A:A").SpecialCells(xlCellTypeConstants)
        Set rg2 = Range("C:C").Find(What:=rg1.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If rg2 Is Nothing Then
            For Each rg3 In Range("C:C").SpecialCells(xlCellTypeBlanks)
                rg3.Value = rg1.Value
                rg3.Offset(, 1).Value = rg1.Offset(, 1).Value
                rg3.Offset(, 2).Value = rg1.Offset(, 1).Value
                    For Each rg4 In Range("B:B").SpecialCells(xlCellTypeConstants)
                        If rg4.Offset(, -1).Value = rg3.Value Then
                            If rg4.Value > rg3.Offset(, 1).Value Then rg3.Offset(, 1).Value = rg4.Value
                            If rg4.Value < rg3.Offset(, 2).Value Then rg3.Offset(, 2).Value = rg4.Value
                        End If
                    Next rg4
                Exit For
            Next rg3
        End If
    Next rg1
End Sub
（mm） 2016/11/28(月) 11:58

有り難う御座います。

βさんの方法で使ってみたところ、
A列が半角英数字の場合に上手く抽出されず、
再投稿しようとおもっていたところでした。

早速試してみたいと思います。

また他に良い方法があればご教授ください。
(AB列は全角の場合や半角の場合など様々です。)
（troro） 2016/11/28(月) 20:10

 たしかにそうなりますね。半角数字や半角英数字や半角英字の場合は。
 そういった場合でも C列に正しく自動記載できる数式は、専門家さんだったら可能だと思います。
 その回答をお待ちください。

 あるいは、C列に関しては、A列をコピペした上で、データタブの重複の削除。
 あっというまの作業です。

（β） 2016/11/28(月) 20:44

 もし、ＶＢＡでいいなら。

 Sub Sample()
    Dim c As Range
    Dim dic As Object
    Dim w As Variant
    Dim n As Variant

    Set dic = CreateObject("Scripting.Dictionary")

    For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
        If Not dic.exists(c.Value) Then dic(c.Value) = Array(Empty, Empty)
        w = dic(c.Value)
        n = c.Offset(, 1).Value
        If IsEmpty(w(0)) Then
            w(0) = n
        Else
            If n > w(0) Then w(0) = n
        End If
        If IsEmpty(w(1)) Then
            w(1) = n
        Else
            If n < w(1) Then w(1) = n
        End If
        dic(c.Value) = w
    Next

    Range("C1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    Range("D1:E1").Resize(dic.Count).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))

 End Sub

（β） 2016/11/28(月) 20:53

 関数初心者ですので、半角対応、作業列を使います。

 F1 : =IF(A1="","",IF(COUNTIF(A$1:A1,A1)=1,A1,""))   これを Ctrl/Shift/Enter で入力し　ずずずっと下までフィルコピー

 C1 : =IFERROR(INDEX(F:F,SMALL(IF($F$1:$F$100<>"",ROW($F$1:$F$100)),ROW(A1))),"")　これも Ctrl/Shift/Enter で下にフィルコピー

 D列、E列は　アップした通り。

（β） 2016/11/28(月) 21:12

マクロの場合でも「統合」を使うのが簡単です。
手操作に慣れちゃうと、わざわざマクロ使わないと思いますが。

 Sub 統合()
    Dim 統合元 As Range, 統合先 As Range

    Set 統合元 = Columns("a:b")
    Set 統合先 = Columns("c")

    統合先.Resize(, 3).ClearContents

    統合先.Consolidate 統合元.Address(, , xlR1C1, True), xlMin, False, True
    Columns("d").Copy Columns("e")
    統合先.Consolidate 統合元.Address(, , xlR1C1, True), xlMax, False, True

 End Sub

（マナ） 2016/11/28(月) 21:56

βさん、有難うございます。
まずは、VBAの方を使用させて貰おうと思います。

不躾ですが、あわせて助けて頂きたいのですが、
以下のようにAB列に付随するC列も一緒にF列・H列に抽出したい場合の対処を教えて頂けないでしょうか？

将来的には、列を増やしてデーターを蓄積することになりそうですので・・・。
　　　

 A列	B列	 C列	D列	E列	　F列	G列	　H列
 ABC氏	20161103 岐阜	ABC氏	20161103　岐阜	20160501　秋田
 ABC氏	20161102 島根	XYZ氏	20151102　山口	20151102　山口
 ABC氏	20160501 秋田	HJK氏	20160101　大阪	20150101　東京
 ABC氏	20161102 島根	TYU氏	20161125　青森	20131212　福岡
 XYZ氏	20151102 山口					
 HJK氏	20150101 東京					
 HJK氏	20160101 大阪					
 TYU氏	20131212 福岡					
 TYU氏	20131212 福岡					
 TYU氏	20161125 青森

宜しくお願い致します。

（tororo） 2016/11/28(月) 23:06

 私がアップしたコードをそのまま利用するなら以下ですが、さらに列を増やして・・・
 といった場合に、変更が面倒ですね。もう少し、tororoさんがメンテしやすいコードを考えてみますが、とりあえず。

 Sub Sample2()
    Dim c As Range
    Dim dic As Object
    Dim w As Variant
    Dim n As Variant
    Dim a As String

    Set dic = CreateObject("Scripting.Dictionary")

    For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
        If Not dic.exists(c.Value) Then dic(c.Value) = Array(Empty, Empty, Empty, Empty)
        w = dic(c.Value)
        n = c.Offset(, 1).Value
        a = c.Offset(, 2).Value
        If IsEmpty(w(0)) Then
            w(0) = n
            w(1) = a
        Else
            If n > w(0) Then
                w(0) = n
                w(1) = a
            End If
        End If
        If IsEmpty(w(2)) Then
            w(2) = n
            w(3) = a
        Else
            If n < w(2) Then
                w(2) = n
                w(3) = a
            End If
        End If
        dic(c.Value) = w
    Next

    Columns("D:H").ClearContents
    Range("D1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    Range("E1:H1").Resize(dic.Count).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items))

 End Sub

（β） 2016/11/29(火) 00:02

βさん、助かります。
御手間をお掛けして申し訳ないです。

バッチリでした。
お蔭様で今日はゆっくり寝れそうです。

有難うございます。
重ねて御礼申し上げます。

また、ご相談することもあろうと思いますが、
よろしくお願い致します。
（tororo） 2016/11/29(火) 00:08

 今後、元データの列が増えた（つまり、それに応じて　展開先の列も増える）場合のメンテも考えると
 コードは長くなりますが、以下のほうがいいと思います。
 ★展開列　のところと　★ここから　★ここまで　の間のコードのみを変更追加すればＯＫですので。
 変更、追加も、アップ済みのコードよりわかりやすいと思います。

 Sub Sample3()
    Dim c As Range
    Dim dic As Object
    Dim w As Variant
    Dim n As Variant
    Dim x As Long
    Dim v As Variant
    Dim k As Variant
    Dim mx As Long
    Dim mn As Long

    Set dic = CreateObject("Scripting.Dictionary")

    For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
        If Not dic.exists(c.Value) Then dic(c.Value) = Array(Empty, Empty, Empty, Empty)
        w = dic(c.Value)
        n = c.Offset(, 1).Value
        x = c.Row
        If IsEmpty(w(0)) Then
            w(0) = n
            w(1) = x
        Else
            If n > w(0) Then
                w(0) = n
                w(1) = x
            End If
        End If
        If IsEmpty(w(2)) Then
            w(2) = n
            w(3) = x
        Else
            If n < w(2) Then
                w(2) = n
                w(3) = x
            End If
        End If
        dic(c.Value) = w
    Next

    ReDim v(1 To dic.Count, 1 To 5)     '★ 展開列 5列
    x = 0
    For Each k In dic
        x = x + 1
        mx = dic(k)(1)  '最大値の行番号
        mn = dic(k)(3)  '最小値の行番号

        v(x, 1) = k
    '★ここから
        With Rows(mx)   '最大値関連列セット
            v(x, 2) = .Columns("B").Value
            v(x, 3) = .Columns("C").Value
        End With

        With Rows(mn)   '最小値関連列セット
            v(x, 4) = .Columns("B").Value
            v(x, 5) = .Columns("C").Value
        End With
    '★ここまで
    Next

    Columns("D:H").ClearContents
    Range("D1").Resize(dic.Count, UBound(v, 2)).Value = v

 End Sub

（β） 2016/11/29(火) 00:23

 ↑　列が増えた場合、最後の２行の展開先列（今はD列～H列）のところも変更必要です。

（β） 2016/11/29(火) 00:28

コメント返信：

[ 一覧(最新更新順) ]

[[20161126004007]] 『A列が同じもののうち、B列の数値が多いものと少な』（tororo） ページの最後に飛ぶ

[[20161126004007]]　『A列が同じもののうち、B列の数値が多いものと少な』（tororo）　ページの最後に飛ぶ