Excel 名寄せ

質問

Ｂ列にフィルターをかけて

　B列　～～～～～　　Ｉ列
１あ社　　　　　　　　　　1号
２あ社　　　　　　　　　　2号
３あ社　　　　　　　　　　3号　

こう表示させたらＩ列のを

　B列　～～～～～　　Ｉ列
１あ社　　　　　　　　　　1号、2号、3号

と名寄せしたいです。2、3行目は削除します。
Ｉ列の数は多くて50号まであります。

　B列　～～～～～　　Ｉ列
１う社　　　　　　　　　　3号
２う社　　　　　　　　　　4号
３う社　　　　　　　　　　7号
４う社　　　　　　　　　　8号

B列　～～～～～　　Ｉ列
１う社　　　　　　　　　　3号、4号、7号、8号

B列の会社も何種類もあるので簡単なやり方があったら教えてください。

回答No.6

tom04 · ベストアンサー

No.4の補足
＞3号が2つあったら1つだけ表示させたいのですが。
の件について・・・

↓のコードにしてみてください。
（今回はI列のみ列幅調整しています）

Sub Sample3()
Dim i As Long, k As Long
For i = Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(Range("B:B"), Cells(i, "B")) > 1 Then
For k = i - 1 To 2 Step -1
If Cells(k, "B") = Cells(i, "B") Then Exit For
Next k
If InStr(Cells(i, "I"), Cells(k, "I")) = 0 Then
Cells(k, "I") = Cells(k, "I") & "、" & Cells(i, "I")
Else
Cells(k, "I") = Cells(i, "I")
End If
Rows(i).Delete
End If
Next i
Columns("I").AutoFit
End Sub

※　さらなる質問でI列の並び替えが出てきそうな感じがしますが、これは考慮していません。
元データのI列そのものは昇順になっているものとします。m(_ _)m

お礼

ほんっとにありがとうございます！

回答No.5

MackyNo1

一般機能と関数を利用した方法を紹介します。

まず準備として、「データ」「並べ替え」でＡ列の会社名で並べ替えておきます。

添付画像は作業がわかりよいようにＢ列に号数を入力していますが、この列が使用されている場合は適宜空白列を選択して１行目のセルに「=I1&" "」の式を入力して下方向にオートフィルしてください（添付画像のように列を２列挿入した場合は参照するセルの位置を変更する）。

次に、Ｂ２セルから下方向に数式セルを選択して右クリック「コピー」もう一度右クリック「形式を選択して貼り付け」で「値」で貼り付けます。

Ｃ２セルに以下の式を入力して下方向にオートフィルします。

=IF(OR(A2="",A1=A2),"",SUBSTITUTE(TRIM(PHONETIC(OFFSET(B2,0,0,COUNTIF(A:A,A2),1)))," ","、"))

最後にＣ列でフィルタして空白セル以外を抽出すればご希望のリストになっていますので（不必要な列を非表示にして）、このセル範囲を選択してコピーして、新規シートに貼り付けてください。

実際の号数の部分にひらがなが入っている場合は、Ｂ列を選択して、ホームタブの「フォント」の中の「ふりがなの設定」から「ひらがな」にチェックを入れてください。

お礼

関数でありがとうございます。

回答No.4

tom04

続けてお邪魔します。

＞出来た後セル幅が変わるのはなぜでしょうか？
は余計なお世話だったかもしれませんね。

前回のコードの
＞Columns.AutoFit
部分で列幅を調整しています。

必要がない場合は、この一行を削除してください。m(_ _)m

お礼

ありがとうございます。
これで楽にできます。

補足

何度もすみません。もうひとつだけ
3号が2つあったら1つだけ表示させたいのですが。

B列　～～～～～　　Ｉ列
１う社　　　　　　　3号
２う社　　　　　　　3号
３う社　　　　　　　7号
４う社　　　　　　　8号

B列　～～～～～　　Ｉ列
１う社　　　　　　　3号、7号、8号
よろしくお願いします。

回答No.3

tom04

何度もごめんなさい。

No.2はトンチンカンなコードを載せています。
無視してください。

↓のコードに訂正してみてください。

Sub Sample2() 'この行から
Dim i As Long, k As Long
For i = Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(Range(Cells(2, "B"), Cells(i, "B")), Cells(i, "B")) > 1 Then
For k = i - 1 To 2 Step -1
If Cells(k, "B") = Cells(i, "B") Then Exit For
Next k
Cells(k, "I") = Cells(k, "I") & "、" & Cells(i, "I")
Rows(i).Delete
End If
Next i
Columns.AutoFit
End Sub 'この行まで

どうも失礼しました。m(_ _)m

お礼

ありがとうございます。できましたー！！

補足

出来た後セル幅が変わるのはなぜでしょうか？

回答No.2

tom04

No.1です。
1行目は項目行になっているというコトですので、
↓のコードに変更してマクロを実行してみてください。

Sub Sample2()
Dim lastRow As Long
Application.ScreenUpdating = False
lastRow = Cells(Rows.Count, "E").End(xlUp).Row
Range(Cells(1, "E"), Cells(lastRow, "E")).AutoFilter field:=1, Criteria1:="従業員A"
If Cells(Rows.Count, "E").End(xlUp).Row > 1 Then '←念のため
Range(Cells(2, "F"), Cells(lastRow, "F")).SpecialCells(xlCellTypeVisible) = "総務課"
End If
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

※　おそらく前回のコードでも大丈夫だったと思いますが、
今度はどうでしょうか？m(_ _)m

回答No.1

tom04

こんにちは！
VBAでの一例です。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）
尚、データは1行目からあるとしています。

Sub Sample1() 'この行から
Dim i As Long, k As Long
For i = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Range(Cells(1, "B"), Cells(i, "B")), Cells(i, "B")) > 1 Then
For k = i - 1 To 1 Step -1
If Cells(k, "B") = Cells(i, "B") Then Exit For
Next k
Cells(k, "I") = Cells(k, "I") & "、" & Cells(i, "I")
Rows(i).Delete
End If
Next i
Columns.AutoFit
End Sub 'この行まで

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

お礼

すみません。2行目からなんです。

補足

1行目はウィンドウ枠固定でB1に会社名とあって
そこでフィルターをかけています。