[[20070525122529]]　『重複するデータを1つだけ残し、列を行に移動したａx（KI）　ページの最後に飛ぶ

『重複するデータを1つだけ残し、列を行に移動したい』（KI）

 Sheet1に、

 　　  　A       B        C         D   
    1    1      山田　 山田住所　 りんご
    2    2      山田　 山田住所　 みかん
    3    3      山田　 山田住所　 もも
    4    1      鈴木　 鈴木住所　 りんご
    5    2      鈴木　 鈴木住所　 もも
    6    1      石井　 石井住所　 りんご
    7    1      本田　 本田住所　 りんご

 とあるものを

 Sheet2に、

         A       B        C         D         E        F
    1    1      山田　 山田住所　 りんご    みかん　  もも
    2    1      鈴木　 鈴木住所　 りんご     もも
    3    1      石井　 石井住所   りんご
    4    1      本田　 本田住所   りんご

 としたいのですが、できますでしょうか？　　
 宜しくお願いいたします。　　Excel2002 WindowsXP

 作業列を配置するものです。配列数式よりは軽いと思いますが、
 広範囲に数式を展開しますと、負荷がかかります。　　　　(6UP)

 Sheet1のA列に列を挿入し、A1に=COUNTIF(B$1:B1,1)として、A7までフィルドラッグ。
 これは、作業列です。

 Sheet2のA1に=MATCH(ROW(A1),Sheet1!A$1:A$7,)として、A7までフィルドラッグ。
 これも作業列です。

 B2に=IF(ISNA($A1),"",INDEX(Sheet1!B$1:B$7,$A1))として、
 コピーして、B1:E7に貼り付け。

 F1に
 =IF(ISNA($A1),"",IF(COLUMN(B2)>COUNTIF(Sheet1!A$1:A$7,ROW(A1)),"",
 INDEX(Sheet1!$E$1:$E$7,$A1+COLUMN(A1))))
 として、D7までフィルドラッグ。さらに右の必要な範囲までフィルドラッグ。

 == Sheet1 ==
 　 A　　B　　 C　　　 D　　　　　 E　　　 F　　　　 G
 1　1　　1　　山田　　山田住所　　りんご
 2　1　　2　　山田　　山田住所　　みかん
 3　1　　3　　山田　　山田住所　　もも
 4　2　　1　　鈴木　　鈴木住所　　りんご
 5　2　　2　　鈴木　　鈴木住所　　もも
 6　3　　1　　石井　　石井住所　　りんご
 7　4　　1　　本田　　本田住所　　りんご
 　↑				
 　=COUNTIF(B$1:B1,1)

 == Sheet2 ==
 1　1　　1　　山田　　山田住所　　りんご　　みかん　　もも
 2　4　　1　　鈴木　　鈴木住所　　りんご　　もも	
 3　6　　1　　石井　　石井住所　　りんご		
 4　7　　1　　本田　　本田住所　　りんご		
 5　#N/A						
 6　#N/A　　　　　　　　　　　　　　　　　　　↑		
 7　#N/A　　　　　　　 =IF(ISNA($A1),"",IF(COLUMN(B2)>COUNTIF(Sheet1!A$1:A$7,ROW(A1)),"",
 　　　　　　　　　　　INDEX(Sheet1!$E$1:$E$7,$A1+COLUMN(A1))))	
 　　　　↑					
 　　　　=IF(ISNA($A1),"",INDEX(Sheet1!B$1:B$7,$A1))					
 　　↑						
 　　=MATCH(ROW(A1),Sheet1!A$1:A$7,)

 ディクショナリで。
 (ROUGE)
'----
Sub test()
Dim tbl, i As Long, x, ky, dic As Object
With Sheets("Sheet1")
    tbl = Intersect(.Range("B1").CurrentRegion, .Range("B:B")).Resize(, 3)
End With
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl, 1)
    ky = tbl(i, 1) & "_" & tbl(i, 2)
    If Not dic.Exists(ky) Then
        dic.Add ky, Array(tbl(i, 1), tbl(i, 2), tbl(i, 3))
    Else
        x = dic(ky)
        ReDim Preserve x(UBound(x) + 1)
        x(UBound(x)) = tbl(i, 3)
        dic(ky) = x
    End If
Next
Sheets("Sheet2").Cells.ClearContents
i = 0
For Each ky In dic.Keys
    x = dic(ky)
    i = i + 1
    Sheets("Sheet2").Cells(i, 1).Value = 1
    Sheets("Sheet2").Cells(i, 2).Resize(, UBound(x) + 1).Value = _
        Application.Transpose(Application.Transpose(x))
Next
Set dic = Nothing
Erase tbl
End Sub

丁寧なご説明を頂き、知識不足と思われる私でもできました
ありがとうございました！

コメント返信：

[ 一覧(最新更新順) ]

[[20070525122529]] 『重複するデータを1つだけ残し、列を行に移動したａx（KI） ページの最後に飛ぶ

[[20070525122529]]　『重複するデータを1つだけ残し、列を行に移動したａx（KI）　ページの最後に飛ぶ