エクセル マクロ？ 関数？ データの抜き出しと

質問

エクセル2010を使っています。

画像のオレンジの部分の様なデータがあります。

Ａ列とＢ列に重複したデータが複数有り、Ｄ列に重複なしの氏名（Ａ列のデータの重複なし）を表記しました。

Ｄ列の上からの氏名のデータをＡ列から探して該当する氏名のＢ列のデータを、Ｅ列、Ｆ列、Ｇ列と右に表示したいと思います。

Ａ列Ｂ列は現状で16000行ほど。

Ｄ列は重複は無く、900行ほどあります。

ですので出来るだけ負担の無い形で抜き出したいです。

詳しい方、よろしくお願い致します。

回答No.2

nishi6 · ベストアンサー

質問にある添付図の構成でE列から右に出力します。（当方Excel2010です）

データ数が多いとのことなので、シートとのI/Oを減らし、Dictionaryオブジェクトを使い、短くしたつもりです。テストデータ１万件程度で１秒弱でした。

何回も行うと、E列より右に上書きするかもしれません。メッセージが出るので「OK」してください。最初、E列より右をクリアしておけばメッセージは出ません。

「Ｄ列に重複なしの氏名」ということを信用して、あまりエラー対応をしていません。ご容赦を。

シートのコードウィンドウに貼り付けます。

Sub TotalTest()
　　Dim myDic As Object　　'Dictionaryオブジェクト
　　Dim myVal, myVal2　　 'シートの値
　　Dim i As Long, idx As Long 'カウンタ

　　'Dictionaryオブジェクト
　　Set myDic = CreateObject("Scripting.Dictionary")

　　'出力欄を取り込む
　　myVal = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value
　　For i = 1 To UBound(myVal)
　　　　myDic.Add myVal(i, 1), i + 1
　　Next
　　'出力欄をクリアし確保（myValを再利用）
　　Range("E:E").ClearContents
　　myVal = Range("E2", "E" & UBound(myVal) + 1).Value

　　'データを取り込み振り分ける（メモリー上でカンマでつなげる）
　　myVal2 = Range("A2", Range("B" & Rows.Count).End(xlUp)).Value
　　For i = 1 To UBound(myVal2)
　　　　idx = myDic.Item(myVal2(i, 1)) - 1
　　　　If myVal(idx, 1) = "" Then
　　　　　　myVal(idx, 1) = myVal2(i, 2)
　　　　Else
　　　　　　myVal(idx, 1) = myVal(idx, 1) & "," & myVal2(i, 2)
　　　　End If
　　Next

　　'出力（カンマ区切り）
　　Range("E2", Range("E" & UBound(myVal) + 1)) = myVal
　　'セルに分割
　　Columns("E:E").Select
　　Selection.TextToColumns Destination:=Range("E1"), Comma:=True
　　Range("E1").Select

　　Set myDic = Nothing
End Sub

お礼

回答ありがとうございます。

お陰さまで一発で目的を果たせる事ができました。

回答No.4

tom04

こんにちは！
すでに回答は出ていますが、VBAでの一例です。

質問では同じSheetのD列以降に表示したい！というコトですが、Sheet2に表示するようにしてみました。
Alt+F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
wS.Cells.Clear
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS.Cells(i, "A")
Range(.Cells(2, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy
wS.Cells(i, "B").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next i
.AutoFilterMode = False
wS.Columns.AutoFit
wS.Activate
Application.ScreenUpdating = True
MsgBox "処理完了"
End With
End Sub 'この行まで

※　関数でないのでデータ変更があるたびにマクロを実行する必要があります。m(_ _)m

お礼

回答ありがとうございます。

助かりました。

回答No.3

bunjii

関数を使う場合は次の数式が良いでしょう。
=IFERROR(INDEX($B:$B,SUMPRODUCT(LARGE(($A:$A=$D2)*ROW($A:$A),COUNTIF($A:$A,$D2)-COLUMN(A1)+1)),1),"")

>Ａ列Ｂ列は現状で16000行ほど。
>Ｄ列は重複は無く、900行ほどあります。
>ですので出来るだけ負担の無い形で抜き出したいです。
動作の状況によって自動計算を止めて手動計算に変更すれば入力時のストレスを軽減できます。
手動計算のときは「ファイル」タブの「オプション」で「数式」の「手動」で「ブックの保存前に再計算を行う」にチェックしてあれば再開のときに最新状態で表示されます。
尚、編集途中での再計算の実行はF9キーです。

お礼

回答ありがとうございます。

関数でも出来るのですね、自分なりに勉強してみたいと思います。

回答No.1

Cupper-2

|ω・`)っ「ピボットテーブル」