Merhaba arkadaşlar, arkadaşlar eklediğim dosyadaki konu hakkında yardımlarınızı umuyorum.......tşkr..
Ekli dosyalar
-
8.6 KB Görüntüleme: 3
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Dosya yok.Merhaba arkadaşlar, arkadaşlar eklediğim dosyadaki konu hakkında yardımlarınızı umuyorum.......tşkr..
Private Sub UserForm_Initialize()
Dim z As Object, a As Long, i As Long, k As Long
ListBox1.ColumnCount = 5
ListBox1.RowSource = "Sayfa1!A2:e" & Cells(65536, "A").End(xlUp).Row
ListBox1.ColumnHeads = True
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To 3, 1 To 1)
For i = 0 To ListBox1.ListCount - 1
If Not z.exists(ListBox1.Column(1, i)) Then
z.Add ListBox1.Column(1, i), ListBox1.Column(3, i)
a = a + 1
ReDim Preserve myarr(1 To 3, 1 To a)
myarr(1, a) = ListBox1.Column(1, i)
myarr(2, a) = CDbl(ListBox1.Column(2, i))
myarr(3, a) = CDbl(ListBox1.Column(4, i))
Else
z.Item(ListBox1.Column(1, i)) = z.Item(ListBox1.Column(1, i)) + ListBox1.Column(2, i)
For k = 1 To UBound(myarr, 2)
If myarr(1, k) = ListBox1.Column(1, i) Then
myarr(2, k) = CDbl(myarr(2, k)) + CDbl(ListBox1.Column(2, i))
myarr(3, k) = CDbl(myarr(3, k)) + CDbl(ListBox1.Column(4, i))
End If
Next k
End If
Next
If a > 0 Then ListBox2.Column = myarr
End Sub
Rica ederim.Evren hocam herseferinde hızırgibi yetişiyorsunuz valla .HELAL SİZE EMEĞİNİZE YÜREĞİNİZE sağlık teşekürler...:dua2::dua2::dua2::dua2::dua2: