- Katılım
- 3 Ağustos 2007
- Mesajlar
- 9
- Excel Vers. ve Dili
- 2007
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Base 1
Sub veri_aktar_topla()
Dim myarr(), list(), a As Long, i As Long, z As Object, n As Long
Dim sh As Worksheet, sure As Date, sure2 As Date
sure = TimeValue(Now)
Sheets("RAPOR").Select
Application.ScreenUpdating = False
Range("A4:I65536").ClearContents
Set sh = Sheets(CStr("REZ"))
list = sh.Range("A3:I" & sh.Cells(65536, "A").End(xlUp).Row).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 9, 1 To UBound(list))
For i = 1 To UBound(list)
If Not z.exists(list(i, 1)) Then
n = n + 1
z.Add list(i, 1), n
myarr(1, n) = list(i, 1)
End If
myarr(5, z.Item(list(i, 1))) = myarr(5, z.Item(list(i, 1))) + list(i, 5)
myarr(6, z.Item(list(i, 1))) = myarr(6, z.Item(list(i, 1))) + list(i, 6)
myarr(8, z.Item(list(i, 1))) = myarr(8, z.Item(list(i, 1))) + list(i, 8)
myarr(9, z.Item(list(i, 1))) = myarr(9, z.Item(list(i, 1))) + list(i, 9)
Next
ReDim Preserve myarr(1 To 9, 1 To n)
Range("A4").Resize(n, 9) = Application.Transpose(myarr)
Set sh = Nothing: Set z = Nothing: Erase myarr()
Application.ScreenUpdating = True
sure2 = TimeValue(Now) - sure
MsgBox "İşlem Başarı ile tamamlandı." & vbLf & "evrengizlen@hotmail.com" & _
vbLf & "SÜRE : " & sure2, vbOKOnly + vbInformation, Application.UserName
End Sub