- Katılım
- 6 Kasım 2005
- Mesajlar
- 300
- Altın Üyelik Bitiş Tarihi
- 06-09-2023
Dosya Ektedir...Yardımlarınız içn şimdiden teşekkürler
Ekli dosyalar
-
10.3 KB Görüntüleme: 9
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub OzetTabloHazirla()
'Microsoft Scripting Runtime Modülü Yüklenmeli (Ben bu yolu tercih ediyom)
Dim dic As New Dictionary
Dim ar1 As Variant
Dim ar2 As Variant
Dim arr As Variant
Dim k As Variant
Dim i As Long
Dim j As Long
Dim kol As Integer
ar1 = Sayfa1.UsedRange.Value
ar2 = Sayfa2.UsedRange.Value
i = UBound(ar1, 1) + UBound(ar2, 1)
If UBound(ar1, 2) > UBound(ar2, 2) Then
kol = UBound(ar1, 2)
Else
kol = UBound(ar2, 2)
End If
ReDim arr(1 To i, 1 To kol)
j = 0
For i = LBound(ar1, 1) To UBound(ar1, 1)
If Not ar1(i, 1) = "" Then
j = j + 1
For kol = LBound(ar1, 2) To UBound(ar1, 2)
arr(j, kol) = ar1(i, kol)
Next kol
End If
Next i
For i = LBound(ar2, 1) To UBound(ar2, 1)
If Not ar1(i, 1) = "" Then
j = j + 1
For kol = LBound(ar2, 2) To UBound(ar2, 2)
arr(j, kol) = ar2(i, kol)
Next kol
End If
Next i
arrList arr
'j = 0
'For i = LBound(arr, 1) To UBound(arr)
' k = arr(i, 1)
' If Not dic.Exists(k) Then
' j = j + 1
' dic.Add k, j
' arr(j, 2) = arr(i, 3)
' Else
' arr(dic.Item(k), 2) = arr(dic.Item(k), 2) + arr(i, 3)
' End If
'Next i
End Sub
Sub arrList(arr As Variant)
Dim i As Long, _
deg As Variant, _
jkey As Long, _
jitm As Long, _
k As Integer, _
dic As New Dictionary, _
ayad As Variant, _
yil As Integer, _
ay As Integer
jkey = 0
For i = LBound(arr, 1) To UBound(arr, 1)
If Not arr(i, 1) = "" Then
deg = arr(i, 1)
If Not dic.Exists(deg) Then
jkey = jkey + 1
dic.Add deg, jkey
arr(jkey, 1) = deg
For k = 2 To UBound(arr, 2)
arr(dic.Item(deg), k) = arr(i, k)
Next k
Else
For k = 2 To UBound(arr, 2)
arr(dic.Item(deg), k) = arr(dic.Item(deg), k) + arr(i, k)
Next k
End If
End If
Next i
Sayfa3.Cells.Clear
Sayfa3.Range("A1") = "ÖZET TABLO"
Sayfa3.Range("A2").Resize(jkey, UBound(arr, 2)) = arr
End Sub
Option Explicit
Sub Multi_Sheets_Pivot_Table()
Dim Sh As Worksheet, My_Data As Variant, X As Long, Y As Byte, Process_Time As Double
Process_Time = Timer
With VBA.CreateObject("Scripting.Dictionary")
For Each Sh In Sheets(Array("Sayfa1", "Sayfa2"))
My_Data = Sh.Range("A3:D" & Sh.Cells(Sh.Rows.Count, 1).End(3).Row).Value
For X = LBound(My_Data, 1) To UBound(My_Data, 1)
If My_Data(X, 1) <> "" Then
For Y = LBound(My_Data, 2) + 1 To UBound(My_Data, 2)
If My_Data(X, Y) <> "" Then .Item(My_Data(X, 1)) = .Item(My_Data(X, 1)) + 1
Next
End If
Next
Next
Sheets("Sayfa3").Range("A:B").Clear
Sheets("Sayfa3").Range("A1") = "ÖZET TABLO"
Sheets("Sayfa3").Range("A1").Font.Bold = True
Sheets("Sayfa3").Range("A2").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
Sheets("Sayfa3").Columns("A:B").AutoFit
End With
MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
"İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye", vbInformation
End Sub
Referans olayını halettiniz mi?necdet bey kod hata verdi...bu işlemi BAĞ_DEĞ_DOLU_Say yapmaktayım ancak verilerim fazla olduğu için formülde hata olabiliyor...bunu başka bir formülle yapma ihtimali olabilir mi?