اداغام چند سلول متنی بر اساس یک شرط در یک سلول دیگر

[nima6223]

دوستان گلم سلام .
یک مشکلی برام پیش اومده خیلی کارم گیر است عزیران محبت نمایید راهنمایی بفرمایید.

یک فایل دیتایی دارم که حدودا 2000 رکورد داره و من میخوام :
1-جمع هر کالا در یک شیت دیگر قرار گیرد
2-در یک سلول مقابل جمع در هر ردیف شماره پروژه های درخواست کنندگان اون کالا درج بشود
نمونه فایل را پیوست کردم شامل دو شیت دیتا و خروجی

[mrhartsclube]

سلام دوست عزیز

تابع مد نظر شما:



Sub Collect()

Dim i As Long, j As Integer, k As Integer

Dim Found As Boolean

k = 1

j = 1

i = 2

Dim Objects() As String, Counts() As Long, ProjNum() As String

ReDim Objects(1)

ReDim Counts(1)

ReDim ProjNum(1)

Objects(k) = (Worksheets("data").Cells(i, "C"))

Counts(k) = (Worksheets("data").Cells(i, "D"))

ProjNum(k) = (Worksheets("data").Cells(i, "B"))

i = 3

While (Worksheets("data").Cells(i, "C") <> "")

Found = False

For j = 1 To UBound(Objects)

If Objects(j) = Worksheets("data").Cells(i, "C") Then

Counts(j) = Val(Counts(j)) + Val((Worksheets("data").Cells(i, "D")))

ProjNum(j) = ProjNum(j) & " " & (Worksheets("data").Cells(i, "B"))

Found = True

Exit For

End If

Next j

If Not Found Then

k = k + 1

ReDim Preserve Objects(k)

ReDim Preserve Counts(k)

ReDim Preserve ProjNum(k)

Objects(k) = (Worksheets("data").Cells(i, "C"))

Counts(k) = (Worksheets("data").Cells(i, "D"))

ProjNum(k) = (Worksheets("data").Cells(i, "B"))

End If

i = i + 1

Wend

For i = 1 To UBound(Objects)

Worksheets("out").Cells(i + 1, "A").Value = Objects(i)

Worksheets("out").Cells(i + 1, "B").Value = Counts(i)

Worksheets("out").Cells(i + 1, "C").Value = ProjNum(i)

Next i

End Sub