Say topla aktar

[ADER_34]

Merhaba arkadaşlar şöyle bir isteğim olacak örnek sayfamda "AW" sütunu ve "BC" sütununda ki dolu satırları "BEKLEYEN" sayfası "A" sütununa alt alta aktar, aktarırken say tekralanan adeti "B" sütununa yaz kolay gelsin teşekkrüler..
ÖRNEK 12347572 sütunda kaç kere tekraranmışsa adetini yaz


http://s4.dosya.tc/server5/ptay2q/PENDING__RAPOR.xls.html

 

[halit3]

KOD:

Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set s1 = Sheets("Data List") ' veri sayfası
Set s2 = Sheets("BEKELEYEN") 'aktarılan sayfa

s2.Range("A2:[COLOR="Red"]C[/COLOR]65000").ClearContents

son1 = 65000

ReDim ara1(son1): ReDim ara2(son1): [COLOR="red"]ReDim ara3(son1):[/COLOR]

For j = 2 To s1.Cells(Rows.Count, "AW").End(3).Row
If s1.Cells(j, "AW") <> "" Then
say = say + 1
ara1(say) = WorksheetFunction.Trim(s1.Cells(j, "AW"))
ara2(say) = 1
[COLOR="red"]ara3(say) = "AW" & j[/COLOR]

End If
Next j

For j = 2 To s1.Cells(Rows.Count, "BC").End(3).Row
If s1.Cells(j, "BC") <> "" Then
say = say + 1
ara1(say) = WorksheetFunction.Trim(s1.Cells(j, "BC"))
ara2(say) = 1
[COLOR="red"]ara3(say) = "BC" & j[/COLOR]
End If
Next j


sat1 = 2

For r = 1 To say
aranan1 = ara1(r)
If ara2(r) = 1 Then
deg1 = 0
[COLOR="red"]deg2 = ""[/COLOR]
For i = 1 To say
If ara1(i) = aranan1 Then
ara2(i) = 0
deg1 = deg1 + 1
[COLOR="red"]deg2 = deg2 & " " & ara3(i)[/COLOR]
End If
Next i

s2.Cells(sat1, "a").Value = aranan1
s2.Cells(sat1, "b").Value = deg1
[COLOR="red"]s2.Cells(sat1, "c").Value = deg2[/COLOR]
sat1 = sat1 + 1
End If

Next r


Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

 

[ADER_34]

Merhaba Halit bey çok teşekkür ederim kodlarınız sorunsuz kolay gelsin..