Vba code to copy unique email id data from input sheet to output sheet

[UPA]

Hi excel guru,

Need your help!

From input sheet from column D i want unique id in output sheet in column D and also in reference to these unique id i want Name,City,Mobile number from input sheet to output sheet in column E i want count of email and in column F Minimum budget and in Column G Maximum budget and in H column bedroom and in I column Locality
i require all unique locality in one cell and also i require all unique Project in one cell.

Please find the attached file for your reference.

Thanks

[UPA]

Hi All,

I have created this macro to automate this report but i stuck at column F to J.

Please help me to automate this report.

Thanks

Sub test()
Dim x As Long
Sheets("Input").Activate
Range("D1:D200").Select
Selection.Copy
Sheets("Output").Activate
Range("D1").Select
ActiveSheet.Paste
Sheets("Output").Select
Columns("D:D").Select
ActiveSheet.Range("$D$1:$D$200").RemoveDuplicates Columns:=1, Header:=xlYes
Range("D2").Select

Sheets("Output").Select
Range("A1") = "Name"
Range("B1") = "City"
Range("C1") = "Mobile"
Range("D1") = "Email"
Range("E1") = "count of email ID in input sheet"
Range("F1") = "Minimum budget"
Range("G1") = "Maximum budget"
Range("H1") = "bedroom"
Range("I1") = "locality"
Range("J1") = "Project"
x = 2
Do While Cells(x, 4) <> ""
Cells(x, 1).Value = Application.WorksheetFunction.Index(Sheets("Input").Range("A:A"), Application.WorksheetFunction.Match(Sheets("Output").Cells(x, 4), Sheets

("Input").Range("D:D"), 0))
Cells(x, 2).Value = Application.WorksheetFunction.Index(Sheets("Input").Range("B:B"), Application.WorksheetFunction.Match(Sheets("Output").Cells(x, 4), Sheets

("Input").Range("D:D"), 0))
Cells(x, 3).Value = Application.WorksheetFunction.Index(Sheets("Input").Range("C:C"), Application.WorksheetFunction.Match(Sheets("Output").Cells(x, 4), Sheets

("Input").Range("D:D"), 0))
Cells(x, 5).Value = "=COUNTIF(Input!C[-1],Output!RC[-1])"
x = x + 1
Loop
End Sub

[karedog]

Maybe :

Sub Test()
  Dim a(), b(), c As New Collection, i As Long, j As Long, p As Long, v
  a = Sheets("Input").Range("A1").CurrentRegion.Value
  ReDim b(1 To UBound(a, 1), 1 To 10)
  For i = 2 To UBound(a, 1)
      On Error Resume Next
         c.Add key:=a(i, 4), Item:=c.Count + 1
      On Error GoTo 0
      p = c(a(i, 4))
      For j = 1 To 4
          b(p, j) = a(i, j)
      Next j
      b(p, 5) = b(p, 5) + 1
      If IsEmpty(b(p, 6)) Or a(i, 5) < b(p, 6) Then b(p, 6) = a(i, 5)
      If a(i, 6) > b(p, 7) Then b(p, 7) = a(i, 6)
      b(p, 8) = b(p, 8) & "|" & a(i, 7)
      b(p, 9) = b(p, 9) & "|" & a(i, 8)
      If a(i, 10) <> "\N" Then b(p, 10) = b(p, 10) & "|" & a(i, 10)
  Next i
  For i = 1 To c.Count
      For j = 8 To 10
          Set c = Nothing
          For Each v In Split(b(i, j), "|")
              On Error Resume Next
                 c.Add key:=CStr(v), Item:=v
              On Error GoTo 0
          Next v
          b(i, j) = vbNullString
          For Each v In c
              b(i, j) = b(i, j) & IIf(Len(b(i, j)), IIf(j = 8, ",", vbCrLf), "") & v
          Next v
      Next j
  Next i
  With Sheets("Output")
    .Range("A1").CurrentRegion.Offset(1).ClearContents
    With .Range("A2").Resize(i - 1, UBound(b, 2))
      .Value = b
      .Borders.Weight = xlThin
    End With
  End With
End Sub

[UPA]

Hi karedog,
Thank you for your reply - much appreciated.
That is exactly what I am looking for.
Thank you!

[karedog]

You are welcome, UPA. Thanks for marking the thread as solved.

Regards