ödeme tipine göre raporlama

[ismail-34]

Excel web ailesine sevgiler saygılar.

Benim pivot table a uyumsuz bir dosyam var. 3 tip ödeme tipi var. ödeme tiplerine göre rapor dosyası oluştursun istiyorum.

yardımcı olabilirseniz sevinirim.

Herkese iyi günler dilerim.

 

[Korhan Ayhan]

Ben bir pivot hazırladım. Belki kullanmak istersiniz.

 

[Necdet]

Merhaba,
Ben de alternatif olsun, kullanıcının isteğine göre hazırladım.

Public Sub Rapor()

Dim col As Collection
Dim arr As Variant
Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim kol As Integer

Dim bsl As Variant

Application.ScreenUpdating = False

bsl = Array("Sıra No", "Mağaza Adı", "Bakiye")
Sayfa2.Cells.ClearContents

Set col = New Collection

arr = Sayfa1.Range("B4").CurrentRegion.Value

On Error Resume Next
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
    col.Add arr(i, 4), arr(i, 4)
Next i
On Error GoTo 0

For k = 1 To col.Count
    kol = (k - 1) * 4 + 1
    With Sayfa2.Cells(1, kol)
        .Value = col(k)
        .Font.Bold = True
        .Font.Size = 14
        .Font.Color = vbRed
    End With
    
    Sayfa2.Cells(2, kol).Resize(1, UBound(bsl) + 1) = bsl
    j = 2
    For i = 2 To UBound(arr, 1)
        If arr(i, 4) = col(k) Then
            j = j + 1
            Sayfa2.Cells(j, kol).Offset(0, 0) = j - 2
            Sayfa2.Cells(j, kol).Offset(0, 1) = arr(i, 2)
            Sayfa2.Cells(j, kol).Offset(0, 2) = arr(i, 3)
        End If
    Next i
Next k

Application.ScreenUpdating = True

MsgBox "Aktarım Tamamlanmıştır....."

End Sub

 

[ismail-34]

Merhaba,
Ben de alternatif olsun, kullanıcının isteğine göre hazırladım.

Public Sub Rapor()

Dim col As Collection
Dim arr As Variant
Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim kol As Integer

Dim bsl As Variant

Application.ScreenUpdating = False

bsl = Array("Sıra No", "Mağaza Adı", "Bakiye")
Sayfa2.Cells.ClearContents

Set col = New Collection

arr = Sayfa1.Range("B4").CurrentRegion.Value

On Error Resume Next
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
    col.Add arr(i, 4), arr(i, 4)
Next i
On Error GoTo 0

For k = 1 To col.Count
    kol = (k - 1) * 4 + 1
    With Sayfa2.Cells(1, kol)
        .Value = col(k)
        .Font.Bold = True
        .Font.Size = 14
        .Font.Color = vbRed
    End With
   
    Sayfa2.Cells(2, kol).Resize(1, UBound(bsl) + 1) = bsl
    j = 2
    For i = 2 To UBound(arr, 1)
        If arr(i, 4) = col(k) Then
            j = j + 1
            Sayfa2.Cells(j, kol).Offset(0, 0) = j - 2
            Sayfa2.Cells(j, kol).Offset(0, 1) = arr(i, 2)
            Sayfa2.Cells(j, kol).Offset(0, 2) = arr(i, 3)
        End If
    Next i
Next k

Application.ScreenUpdating = True

MsgBox "Aktarım Tamamlanmıştır....."

End Sub

Tam istediğim gbi hocam emeğinize sağlık. çok harika olmuş.

 

[Necdet]

Tam istediğim gbi hocam emeğinize sağlık. çok harika olmuş.

Güle güle kullanınız. Fakat Korhan Bey'in önerisi Pivot table'ı da dikkate alın, pratiktir.

 

[ismail-34]

Ben bir pivot hazırladım. Belki kullanmak istersiniz.

Teşekkürler Hocam ama patronlar hep alıştığı- istediği formatta rapor sunulmasını isterler. bizimki bu tür bişeyi kabul etmeyecektir eminim.emeğinize sağlık

 

[Necdet]

Anladım, patronları ikna etmek zordur, patron hep haklıdır, bilirim

 

[ismail-34]

Anladım, patronları ikna etmek zordur, patron hep haklıdır, bilirim

Aynen Hocam mesela 0 olan bakiyeleri görmek istemiyor ) . 0 olan bakiyeleri aktarmaması için bir ekleme yapmanız mümkünmü acaba ?

 

[Necdet]

Merhaba,

Deneyiniz.

Public Sub Rapor()

Dim col As Collection
Dim arr As Variant
Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim kol As Integer

Dim bsl As Variant

Application.ScreenUpdating = False

bsl = Array("Sıra No", "Mağaza Adı", "Bakiye")
Sayfa2.Cells.ClearContents

Set col = New Collection

arr = Sayfa1.Range("B4").CurrentRegion.Value

On Error Resume Next
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
    col.Add arr(i, 4), arr(i, 4)
Next i
On Error GoTo 0

For k = 1 To col.Count
    kol = (k - 1) * 4 + 1
    With Sayfa2.Cells(1, kol)
        .Value = col(k)
        .Font.Bold = True
        .Font.Size = 14
        .Font.Color = vbRed
    End With
    
    Sayfa2.Cells(2, kol).Resize(1, UBound(bsl) + 1) = bsl
    j = 2
    For i = 2 To UBound(arr, 1)
        If arr(i, 4) = col(k) Then
            If arr(i, 3) > 0 Then
                j = j + 1
                Sayfa2.Cells(j, kol).Offset(0, 0) = j - 2
                Sayfa2.Cells(j, kol).Offset(0, 1) = arr(i, 2)
                Sayfa2.Cells(j, kol).Offset(0, 2) = arr(i, 3)
            End If
        End If
    Next i
Next k

Application.ScreenUpdating = True

MsgBox "Aktarım Tamamlanmıştır....."

End Sub

 

[ismail-34]

Merhaba,

Deneyiniz.

Public Sub Rapor()

Dim col As Collection
Dim arr As Variant
Dim i   As Long
Dim j   As Long
Dim k   As Integer
Dim kol As Integer

Dim bsl As Variant

Application.ScreenUpdating = False

bsl = Array("Sıra No", "Mağaza Adı", "Bakiye")
Sayfa2.Cells.ClearContents

Set col = New Collection

arr = Sayfa1.Range("B4").CurrentRegion.Value

On Error Resume Next
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
    col.Add arr(i, 4), arr(i, 4)
Next i
On Error GoTo 0

For k = 1 To col.Count
    kol = (k - 1) * 4 + 1
    With Sayfa2.Cells(1, kol)
        .Value = col(k)
        .Font.Bold = True
        .Font.Size = 14
        .Font.Color = vbRed
    End With
 
    Sayfa2.Cells(2, kol).Resize(1, UBound(bsl) + 1) = bsl
    j = 2
    For i = 2 To UBound(arr, 1)
        If arr(i, 4) = col(k) Then
            If arr(i, 3) > 0 Then
                j = j + 1
                Sayfa2.Cells(j, kol).Offset(0, 0) = j - 2
                Sayfa2.Cells(j, kol).Offset(0, 1) = arr(i, 2)
                Sayfa2.Cells(j, kol).Offset(0, 2) = arr(i, 3)
            End If
        End If
    Next i
Next k

Application.ScreenUpdating = True

MsgBox "Aktarım Tamamlanmıştır....."

End Sub

Necdet hocam eyw patron gıkını çıkaramadı ama şapka çıkardı valla yine isviçre saati gibi çalışıyor. emeğinize sağlık herşey gönlünüzce olsun.

 

[Necdet]

hiç isviçre saatim olmadı, onu bilemem dee güle güle kullanın