Macroyla Ozet Tablo

[Eser Gökay]

Arkadaslar merhabalar

2 sayfadan bazı verilerin 3. sayfa'ya özetlenmesi ile ilgili olarak macroya ihtiyacım var. ilgilerinizi rica eder iyi calismalar dilerim.

 

[Ferhat Pazarçevirdi]

Aşağıdaki makroyu kullanabilirsiniz. Örnek dosyayı da inceleyiniz...

Option Explicit
Dim arr()
[COLOR=darkgreen]'-------------------------------------------[/COLOR]
Sub Ozetle()
 
    Sheets("Sayfa3").Range("B4:G26").ClearContents
 
    Call Derle_Toparla(Sheets("Sayfa1"))
    Sheets("Sayfa3").Range("B4").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
    Call Derle_Toparla(Sheets("Sayfa2"))
    Sheets("Sayfa3").Range("E4").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
 
End Sub
[COLOR=darkgreen][B]'----------------------------------------[/B][/COLOR]
Sub Derle_Toparla(sh As Worksheet)
    Dim col As New Collection
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
 
    On Error Resume Next
 
    Erase arr
 
    For i = 2 To sh.Cells(65536, "K").End(xlUp).Row
 
        col.Add sh.Cells(i, "K"), sh.Cells(i, "K")
 
        If Err.Number = 0 Then
            x = x + 1
            ReDim Preserve arr(1 To 3, 1 To x)
            arr(1, x) = sh.Cells(i, "K")
            arr(2, x) = sh.Cells(i, "L")
            If sh.Name = "Sayfa2" Then
                arr(3, x) = sh.Cells(i, "N")
            Else
                arr(3, x) = sh.Cells(i, "M")
            End If
        Else
            For j = 1 To UBound(arr)
                If arr(1, j) = sh.Cells(i, "K") Then
                    Exit For
                End If
            Next j
            arr(2, j) = arr(2, j) + sh.Cells(i, "L")
            If sh.Name = "Sayfa2" Then
                arr(3, j) = arr(3, j) + sh.Cells(i, "N")
            Else
                arr(3, j) = arr(3, j) + sh.Cells(i, "M")
            End If
        End If
        Err.Number = 0
    Next i
 
    arr = Application.WorksheetFunction.Transpose(arr)
 
    On Error GoTo 0
End Sub

 

[Eser Gökay]

Ferhat bey çok tesekkur eder iyi calismalar dilerim. Çok Makbule geçti.

 

[Eser Gökay]

Option Explicit

Dim arr()

Sub Ozetle()

Sheets("Stok").Range("B4:G123").ClearContents

Call Derle_Toparla(Sheets("Gid"))
Sheets("Stok").Range("B4").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

Call Derle_Toparla(Sheets("Gel"))
Sheets("Stok").Range("E4").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

End Sub



Ferhat bey kodları kendi dosyama uyarlarken yukarıda işaretlediğim alanda sıkıntı oldu. sebebini anlayamadım. yardımcı olur musunuz ?

 

[Ferhat Pazarçevirdi]

Eğer belirtiğiniz satırda hata alıyorsanız, "arr" dizisine; alt prosedürden veri yüklenmiyor -yani dizi boş olarak geliyor- demektir.

Bu durumda benim aklıma gelen, orjinal dosyanızda; örnekteki gibi K, L, M sütunlarında veri olup olmadığı ....

Eğer, orjinal dosyada bu sütunları kulanmıyorsanız, ya böyle hata verecek ya da -birkaç hata kontrolü eklediğimiz varsayımıyla-, hiç bir bilgi gelmeyecektir.

Kontrol ediniz. İçinden çıkamazsanız, orjinalin aynısı örnek basit bir dosya ilave ediniz.

 

[Eser Gökay]

merhabalar bugun internette sıkıntı yaşıyoruz. Kusura bakmayın ancak açabildim. evet sayfanın birinde yanlış sutun seçmişim onu düzelttim örnekleri de koyunca gayet sağlıklı çalışıyor. Ancak bahsettiginiz hata kontrollerini indirgemek mumkun olur mu ? veri varsa raporu versin değilse boş versin gibi.

 

[Ferhat Pazarçevirdi]

En basiti;

Sheets("Stok").Range("B4:G123").ClearContents

satırının altına

On Error Resume Next

yazmanız kafi gelecektir.

 

[Eser Gökay]

tesekkur ediyorum. iyi calismalar diliyorum.