【至急】Excel 同一人物の情報を一行にまとめる(複数行)

■メールアドレス　　　■A　　■B　　■C
　[e-mail]　　　有　　　　　　有
　[e-mail]　　　有　　　有　
　[e-mail]　　　　　　　有

同一人物のデータが何度も入力されていて、それぞれの行で情報量がバラバラです。
単純に重複と扱って１行目以降を削除するわけにいきません。

そこで、メールアドレスを基に、その他の情報は一行にまとめたいです。
どう処理すれば可能でしょうか。

まとめたい情報列はA列～I列まであります。
約500行です。


■メールアドレス　　　■A　　■B　　■C
　[e-mail]　　　有　　　　　　有
　[e-mail]　　　有　　　有　
　[e-mail]　　　　　　　有


　↓↓↓↓↓↓↓↓↓↓↓↓↓↓

■メールアドレス　　　■A　　■B　　■C
　[e-mail]　　　有　　　有　　有
　[e-mail]　　　有　　　有　

以下のマクロで実行してみましたが、エラーとなって上手くいきません。
恐らく「SpecialCells(xlCellTypeVisible)」でエラーとなっています。

Sub Sample1() 'この行から//
Dim i As Long, lastRow1 As Long, lastRow3 As Long
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS2.Range("A1"), unique:=True
For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
wS3.Cells.ClearContents
.Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, "A")
Range(.Cells(2, "A"), .Cells(lastRow1, "I")).SpecialCells(xlCellTypeVisible).Copy wS3.Range("A1")
lastRow3 = wS3.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS3.Cells(1, "A"), wS3.Cells(lastRow3, "I")).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
Range(wS3.Cells(1, "B"), wS3.Cells(1, "I")).Copy wS2.Cells(i, "B")
Next i
.AutoFilterMode = False
wS3.Cells.Clear
wS2.Columns.AutoFit
End With
Application.ScreenUpdating = True
wS2.Activate
End Sub 'この行まで//


宜しくお願いします。

質問者からの補足コメント

• 

  皆様ご支援ありがとうございます！
  優しさと知識量に感動しています。。。
  少し動きが変わりまして、
  以下のようなマクロに変更したいのですが、知識が足りな過ぎて分かりません！
  ご教示の程よろしくお願いいたします！
  
  添付ファイルの上の表が元データ（Aファイル）このファイルは随時更新されるので、定期的にマクロを実行します。
  Aファイルでマクロを実行して、Bファイルに情報をまとめた表を出力したいです。（毎回Bファイルに結果が出るようにする）

  
    補足日時：2022/05/25 09:40

No.5 ベストアンサー 回答者： fujillin 回答日時： 2022/05/25 00:04

こんばんは

No2様に1票。
エラーの内容が不明ですが、SpecialCells()でエラーが出る場合、該当するセルが存在しないケースが多いです。

・SpecialCells(xlCellTypeVisible)
通常ならあり得ますが、ご提示の処理の場合は、抽出した値でフィルターをかけているので、最低でも1行は該当行が存在するはずなので、エラーになるとは思いにくいです。

・SpecialCells(xlCellTypeBlanks)
元データが全て「有」で埋まっている場合は、該当するセルが存在しないため、エラーになる可能性がありそうです。


シートの機能を利用する計算方法を採用なさっていると思いますが、作業用のシートを使わずとも処理は可能とそうに思います。
以下は、関数を利用して処理を行う例ですが、ご参考までに。
面倒な部分は関数にして、エクセルに計算してもらうようにしていますので、マクロそのものは比較的簡単な内容になっていると思います。(笑)
・1行目はタイトル行と仮定しています。
・元データがあるのがSheet1、結果をSheet2に表示する例です。
・セルの値が、「有」かそれ以外かで判断しています。

Sub Sample()
Dim ws As Worksheet
Dim r1 As Range, r2 As Range
Dim n As Long
Const f = "=IF(SUMPRODUCT((Sheet1!@1=$A2)*(Sheet1!@2=""有"")),""有"","""")"

Set ws = Worksheets("Sheet1")
n = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set r1 = ws.Range("A2").Resize(n)

With Worksheets("Sheet2")
.Cells.UnMerge
.Cells.ClearContents
ws.Range("A1:I1").Copy .Range("A1")
r1.Copy .Range("A2")
.Range("A2").Resize(n).RemoveDuplicates 1
n = .Cells(Rows.Count, 1).End(xlUp).Row
If n < 2 Then Exit Sub

Set r2 = .Range("B2").Resize(n - 1, 8)
r2.FormulaLocal = Replace(Replace(f, "@1", r1.Address(1)), "@2", r1.Offset(, 1).Address(1, 0))
r2.Value = r2.Value
End With
End Sub

No.6 回答者： Qchan1962 回答日時： 2022/05/25 10:50

#2　です

本ご質問は掲示されたエラーについて原因と対策だと存じます

内容が変わったのなら、各回答への対応などを行ってご質問を閉じ、
再質問をしてください（D・・項目の有無や　*セルの意味も気になりますしね）

後から、ご質問タイトルなどで訪れた方の為にも　同じご質問内での再質問は控えた方が良いと思います。

No.4 回答者： めぐみん_ 回答日時： 2022/05/24 19:05

取り敢えずデータはＡ～Ｉ列で今回問題となるのはＢ～Ｄ列だけで、Ｅ列以降はＡ列が重複しててもデータに相違はないと思って宜しいのでしょうか？

⇒逆に相違があるならどうするのかとか、実はＢ～Ｄ列ではなくＢ～Ｉ列が詰める範囲になっているとか？

No.3 回答者： taunamlz 回答日時： 2022/05/24 18:39

初期状態を以下の状態とします。

A列：■メールアドレス
B列：■A
C列：■B
D列：■C
※つまり、A2が「[e-mail]」、A3が「[e-mail]」の状態


１）
E2のセルに以下の式を記入します。
=IF(B2="有",1,0)
※B2のセルが"有"だったら1を、そうでなかったら0を表示する

２）
E2のセルを、E2からG4までコピペします。

３）
H列に、メールアドレスをコピペ後、H列を選んだ状態でExcelのメニューから、「データ」→「重複削除」で、選択されている範囲だけ重複削除します。

４）
I2のセルに以下の式を記入します。
=SUMIFS(E2:E4,$A2:$A4,$H2)
※H2とA2～A4の値が一致する行があったら、E2～E4の合計値を表示する

５）
I2のセルを、I2からK3までコピペします。

これで、H列からK列までを見ると、「有」にしたいセルに「１以上の値」が表示されていると思います。
どうしても「有」を表示したいのであれば、更に「=if()」を使用してください。

No.2 回答者： Qchan1962 回答日時： 2022/05/24 18:38

こんにちは

ちょっと試していませんが
良くあるのは
SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp　こっちでは？
ここなら、作業シートにしているws３に空白セルがない場合発生するかも・・・
SpecialCells(xlCellTypeVisible).Copyは
wS2.Cells(i, "A")該当しない値ってあるのかな・・

取り合えず　On Error Resume Next　で処理を飛ばすと結果が変わる？かな

No.1 回答者： zongai 回答日時： 2022/05/24 18:28

とりあえずマクロコピペで試しましたが、

エラーは出ず、想定していると思われる結果になりましたよ。

どんなエラーが出ているのか、それが鍵になると思います。
補足投稿しましょう。