Tabloyu sadeleştirmek ?

[igultekin2000]

iyi günler; mutad olarak her ay gelen listeyi formüllerle işler hale getiriyorum. Bunu makroya çevirerek işlemi pratikleştirmek iyi olacaktır. Yeteri kadar makro bilgim yoktur. gelen master çalışma sayfasında öncelikle D (ISLEM) sütununda süzme yaparak Tarih ve REF.NO sütunlarını kopyalayıp satis çalışma sayfasına kopyalayıp yenilenen değerleri kaldırıyorum. çok etopla formülü ile fatura numarasına göre bir kaç satır olana değerleri tek satır haline getiriyorum. aynı işlemi iadeler çalışma sayfası için de yapıyorum. işlemde kullandığım sütunları A-Tarih, B-REF.NO, AD-KDV Oranı, AE-Matrah, AF-KDV , D-Fatura/Perakende/İade, T-Nakit, V-Kredi1, X-Kredi2, Z-Kredi3

 

[Ziynettin]

Merhaba;

Dosyanız ekte..

Option Explicit
Sub Satis_iade()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim a(), b(), d As Object, deg As Variant
Dim i As Long, Say As Long, sat As Long
Application.ScreenUpdating = False
Set s1 = Sheets("master")
Set s2 = Sheets("satis")
Set s3 = Sheets("iade")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("A2:AF" & s1.Range("A" & Rows.Count).End(3).Row)
For i = 1 To UBound(a)
    deg = a(i, 1) & a(i, 2)
    If a(i, 4) <> "Iade" Then
    If Not d.exists(deg) Then
        Say = Say + 1
        d(deg) = Say
    End If
    End If
Next i
ReDim b(1 To d.Count, 1 To 8)
For i = 1 To UBound(a)
If a(i, 4) <> "Iade" Then
    deg = a(i, 1) & a(i, 2)
    sat = d(deg)
    b(sat, 1) = Format(a(i, 1), "dd.mm.yyyy")
    b(sat, 2) = a(i, 2)
    If a(i, 30) = 8 Then
        b(sat, 3) = b(sat, 3) + a(i, 31)
        b(sat, 4) = b(sat, 4) + a(i, 32)
    End If
    If a(i, 30) = 18 Then
        b(sat, 5) = b(sat, 5) + a(i, 31)
        b(sat, 6) = b(sat, 6) + a(i, 32)
   End If
   b(sat, 7) = b(sat, 7) + a(i, 20)
   b(sat, 8) = b(sat, 8) + a(i, 22) + a(i, 24) + a(i, 26)
End If
Next i
s2.Range("A2:H" & Rows.Count).ClearContents
s2.[A2].Resize(d.Count, 8) = b
s2.[C2].Resize(d.Count, 6).NumberFormat = "#,##0.00"
Erase b
d.RemoveAll
sat = 0
Say = 0
'************************************************************
For i = 1 To UBound(a)
    deg = a(i, 1) & a(i, 2)
    If a(i, 4) = "Iade" Then
    If Not d.exists(deg) Then
        Say = Say + 1
        d(deg) = Say
    End If
    End If
Next i

ReDim b(1 To d.Count, 1 To 8)
For i = 1 To UBound(a)
If a(i, 4) = "Iade" Then
    deg = a(i, 1) & a(i, 2)
    sat = d(deg)
    b(sat, 1) = Format(a(i, 1), "dd.mm.yyyy")
    b(sat, 2) = a(i, 2)
    b(sat, 3) = b(sat, 3) + a(i, 31)
    b(sat, 4) = b(sat, 4) + a(i, 32)
    b(sat, 5) = b(sat, 5) + a(i, 20)
    b(sat, 6) = b(sat, 6) + a(i, 22) + a(i, 24) + a(i, 26)
End If
Next i
s3.Range("A2:F" & Rows.Count).ClearContents
s3.[A2].Resize(d.Count, 8) = b
s3.[C2].Resize(d.Count, 4).NumberFormat = "#,##0.00"
Erase b
d.RemoveAll
sat = 0
Say = 0
Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

 

[igultekin2000]

sorunsuz çalışıyor

Merhaba;

Dosyanız ekte..

Option Explicit
Sub Satis_iade()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim a(), b(), d As Object, deg As Variant
Dim i As Long, Say As Long, sat As Long
Application.ScreenUpdating = False
Set s1 = Sheets("master")
Set s2 = Sheets("satis")
Set s3 = Sheets("iade")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("A2:AF" & s1.Range("A" & Rows.Count).End(3).Row)
For i = 1 To UBound(a)
    deg = a(i, 1) & a(i, 2)
    If a(i, 4) <> "Iade" Then
    If Not d.exists(deg) Then
        Say = Say + 1
        d(deg) = Say
    End If
    End If
Next i
ReDim b(1 To d.Count, 1 To 8)
For i = 1 To UBound(a)
If a(i, 4) <> "Iade" Then
    deg = a(i, 1) & a(i, 2)
    sat = d(deg)
    b(sat, 1) = Format(a(i, 1), "dd.mm.yyyy")
    b(sat, 2) = a(i, 2)
    If a(i, 30) = 8 Then
        b(sat, 3) = b(sat, 3) + a(i, 31)
        b(sat, 4) = b(sat, 4) + a(i, 32)
    End If
    If a(i, 30) = 18 Then
        b(sat, 5) = b(sat, 5) + a(i, 31)
        b(sat, 6) = b(sat, 6) + a(i, 32)
   End If
   b(sat, 7) = b(sat, 7) + a(i, 20)
   b(sat, 8) = b(sat, 8) + a(i, 22) + a(i, 24) + a(i, 26)
End If
Next i
s2.Range("A2:H" & Rows.Count).ClearContents
s2.[A2].Resize(d.Count, 8) = b
s2.[C2].Resize(d.Count, 6).NumberFormat = "#,##0.00"
Erase b
d.RemoveAll
sat = 0
Say = 0
'************************************************************
For i = 1 To UBound(a)
    deg = a(i, 1) & a(i, 2)
    If a(i, 4) = "Iade" Then
    If Not d.exists(deg) Then
        Say = Say + 1
        d(deg) = Say
    End If
    End If
Next i

ReDim b(1 To d.Count, 1 To 8)
For i = 1 To UBound(a)
If a(i, 4) = "Iade" Then
    deg = a(i, 1) & a(i, 2)
    sat = d(deg)
    b(sat, 1) = Format(a(i, 1), "dd.mm.yyyy")
    b(sat, 2) = a(i, 2)
    b(sat, 3) = b(sat, 3) + a(i, 31)
    b(sat, 4) = b(sat, 4) + a(i, 32)
    b(sat, 5) = b(sat, 5) + a(i, 20)
    b(sat, 6) = b(sat, 6) + a(i, 22) + a(i, 24) + a(i, 26)
End If
Next i
s3.Range("A2:F" & Rows.Count).ClearContents
s3.[A2].Resize(d.Count, 8) = b
s3.[C2].Resize(d.Count, 4).NumberFormat = "#,##0.00"
Erase b
d.RemoveAll
sat = 0
Say = 0
Application.ScreenUpdating = True
MsgBox "İşlem bitti...", vbInformation
End Sub

çok teşekkürler, bayağı karışıktı ama çözmüşünüz elinize sağlık.

 

[Ziynettin]

Rica ederim.
İyi çalışmalar...