- Katılım
- 4 Ocak 2010
- Mesajlar
- 2,074
- Excel Vers. ve Dili
- OFFICE 2007 PRO TR - Win7 X64
- Altın Üyelik Bitiş Tarihi
- 18.06.2019
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Base 1
Sub topla_59()
Dim z As Object, a(), myarr(), n As Long, sat As Long, i As Byte, sh As Worksheet
Dim sat2 As Integer, j As Long, deg As String
Sheets("Sayfa7").Select
Range("A4:C65536").ClearContents
sat2 = Cells(65536, "M").End(xlUp).Row
If sat2 < 2 Then Exit Sub
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To 3, 1 To 65533)
For i = 2 To sat2
Set sh = Sheets(Cells(i, "M").Value)
sat = sh.Cells(65536, "B").End(xlUp).Row
If sat > 3 Then
a = sh.Range("B4:D" & sat).Value
For j = 1 To UBound(a, 1)
deg = a(j, 1) & "-" & a(j, 2)
If Not z.exists(deg) Then
n = n + 1
z.Add deg, n
myarr(1, n) = a(j, 1)
myarr(2, n) = a(j, 2)
End If
myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + a(j, 3)
Next j
End If
Next i
If n > 0 Then
Erase a
Application.ScreenUpdating = False
ReDim Preserve myarr(1 To 3, 1 To n)
Range("A4").Resize(n, 3) = Application.Transpose(myarr)
Application.ScreenUpdating = True
Set sh = Nothing
MsgBox "Verielr akatarıldı" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
Erase myarr
End Sub
Formül konusunda uzman arkadaşlar sorunuza bakacaktır.Selamlar,
Evren hocam vermiş oldugunuz zaman ve emek için teşekkürler sağolun..
Hocam bir şey rica etsem kızmazsınız inşallah ..
hocam ben kodlara biraz uzak oldugum için pek anlayamadım rica etsem ....
formüller bi çözüm yolu varmıdır...
Sayın.Selimkalac sizede teşkkürler
.Selamlar,
Sitede araştırma yaptım en son tek ölçüde göre toplam alma vardı sayfalar arası.
Benim Yapmak istediğim birden fazla ölçüde göre toplam almak .
Örnek dosya ekdedir.
Şimdiden Teşekkürler.