Excelシート個数の少ない氏名をリストアップ

質問

ExcelでB列の個数の少ない順に３個選出しA列ののマッチする氏名をD列に入力したいのですがVBAコードが解る方よろしくお願いします。尚、同個数は氏名入力となります。

回答No.4

jin34 · ベストアンサー

回答３より、
同一シート内で作業するなら、A,B列に行挿入して作業列として使えばいいと思います。
１）A,B列に行挿入
２）B列に連番を振る（後で戻す時のために）
３）D列の値でソート
４）ループしながらA列に順位を振る
５）A列のセルの値が４になったらループ終了。
そのセルより上の行にあるD列の値をコピーしてF列にはる。
６）元の表をB列の値でソート
７）A、B列を削除して終了。

Sub test()

Dim i As Integer, j As Integer

Columns("A:B").Columns.Insert
i = Range("C65536").End(xlUp).Row
For j = 1 To i
Range("B" & j).Value = j
Next j
Range("B1").Sort Range("D1"), xlAscending

Range("A1").Value = 1

For j = 2 To i

If Range("D" & j).Value = Range("D" & j - 1).Value Then
Range("A" & j).Value = Range("A" & j - 1).Value
Else
Range("A" & j).Value = Range("A" & j - 1).Value + 1
If Range("A" & j).Value = 4 Then
Range("C1:C" & j - 1).Copy Range("F1")
Exit For
End If

End If

Next j

Range("B1").Sort Range("B1"), xlAscending
Columns("A:B").Delete

End Sub

マクロなしでどうやってマニュアル作業で行うかを考える力をつけるべきかと思います。
作業列、作業用シートはエクセルではよく使います。
この回答も回答３からの応用でできますよ。
、

お礼

有難うございます。非常に助かりました。

回答No.3

jin34

作業用にSheet2を使います。
Sheet1のデータをSheet2に写し、B列の昇順でならべかえ、
ループしながらC列の i 行目に○番目を振っていきます。
( B列の i 行目の値が (i - 1)行目のそれとちがう時に１加算する。初期値は１）。
でもってC列 i 行目の値が４になったらセルA1からB列の i - 1行目までをコピーして
Sheet1のセルD1に貼り付けて終了です。

Sub test()

Dim i As Integer, j As Integer
Sheets("Sheet1").Range("A1").CurrentRegion.Copy Sheets("Sheet2").Range("A1")

With Sheets("Sheet2")
　.Activate
　.Range("A1").Sort Range("B1"), xlAscending
　.Range("C1").Value = 1
　i = 2
　Do While .Range("A" & i).Value <> ""
　If .Range("B" & i).Value = .Range("B" & i - 1).Value Then
　　.Range("C" & i).Value = .Range("C" & i - 1).Value
　　Else
　　.Range("C" & i).Value = .Range("C" & i - 1).Value + 1
　　If .Range("C" & i).Value = 4 Then
　.Range("A1:B" & i - 1).Copy Sheets("Sheet1").Range("D1")
　.Cells.Clear
　Sheets("Sheet1").Activate
　Exit Sub
　　End If
　End If
　i = i + 1
　Loop
End With

End Sub

お礼

有難うございます。処理は完璧ですが、何とかそのシート内での処理はできないのかなーと思っています。

回答No.2

tom04

こんばんは！
一例です。

元データはSheet1とします。
Sheet2・Sheet3を作業用のSheetとして使用していますので、
Sheet2・3は全く使っていない状態にしておいてください。

標準モジュールに

Sub Sample1()
Dim i As Long, wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet, tmp
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
i = wS1.Cells(Rows.Count, 1).End(xlUp).Row
Range(wS1.Cells(1, 2), wS1.Cells(i, 2)).Copy wS3.Cells(2, 1)
With wS3.Cells(1, 1).CurrentRegion
.Sort key1:=wS3.Cells(1, 1), order1:=xlAscending, Header:=xlYes
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End With
i = wS3.Cells(Rows.Count, 1).End(xlUp).Row
Range(wS3.Cells(1, 1), wS3.Cells(i, 1)).Copy wS2.Cells(1, 1)
tmp = wS2.Cells(4, 1)
wS1.Cells(1, 1).CurrentRegion.Copy wS2.Cells(2, 1)
With wS2.Cells(1, 2).CurrentRegion
.Sort key1:=wS2.Cells(1, 2), order1:=xlAscending, Header:=xlYes
.AutoFilter field:=2, Criteria1:="<=" & tmp
End With
i = wS2.Cells(Rows.Count, 1).End(xlUp).Row
Range(wS2.Cells(2, 1), wS2.Cells(i, 1)).Copy wS1.Cells(1, 4)
wS2.Range("A:B").Delete
With wS3
.Cells(1, 1).AutoFilter
.Range("A:A").Delete
End With
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

有難うございます。助かりました。コードが難しいですが何とか勉強します。

回答No.1

jin34

ならべかえてコピー＆ペーストすればいいだけのことですね。
それとも別のプログラムの中の一部として必要なのでしょうか。

お礼

有難うございます。