Belli kriterleri sağlayan fatura listesini oluşturmak

D

dost

Katılım
15 Mart 2005
Mesajlar
380
Excel Vers. ve Dili
Microsoft 365 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba arkadaşlar,

Ekte sunulu excel dosyasında "Veri" sayfasında veriler mevcut.

Bu verilere göre;

Koşul 1) Fatura tutarı >=10.000 olanları (bu koşulu sağlayan firmanın tüm faturalarını)
Koşul 2) Aynı firmaya ait Faturaların toplamı >=30.000 olanları
Koşul 3) 1.ve 2. koşuldaki bulunan faturaların toplamı Veri sayfasındaki faturaların toplamının % 70'ini sağlıyorsa işlem sonlanacak, sağlamıyor ise 1.ve 2. koşulda gelmeyen faturalardan büyükten küçüğe doğru 1 ve 2. kritere göre bulunan fatura listesine Veri sayfasındaki faturaların toplamının % 70'ini sağlayana kadar ilave edilecek. (Önemli bir ayrıntı: sıralamada bulunan faturanın firmasının başka faturası varsa o faturada listeye ilave edilecek.)

Bu 3 koşula göre oluşan liste Sonuç sayfasında mevcut.

Yapmayı düşündüğüm ancak biraz karışık geldiği için sizlerin fikrine ve bilgilerinize ihtiyaç duymaktayım.

C++: 
strSQL = " SELECT [Veri$].[Firma Kodu] FROM [Veri$] " & _
             " INNER JOIN (SELECT [Firma Kodu] FROM [Veri$] " & _
             " WHERE [Fatura Tutari] >= 10000 GROUP BY [Firma Kodu]) As a " & _
             " ON a.[Firma Kodu] = [Veri$].[Firma Kodu] " & _
             " UNION " & _
             " SELECT [Firma Kodu] " & _
             " FROM [Veri$] " & _
             " GROUP BY [Firma Kodu] HAVING SUM([Fatura Tutari]) >=30000 "
1) Yukarıda SQL kodu ile 1.ve 2. kriteri sağlayan firmaları bulup TMP sayfasına aktarmak.
2) Döngüye girerek bu firmaların faturalarını listelemek. (Listeler iken faturaların toplamını değişkene atamak)
3) Sonrasında Veri sayfasındaki faturaların %70 ile değişkene attığım toplamı karşılaştırmak......

Sonuç sayfasındaki listeyi tek SQL ile veya başka bir yöntem ile nasıl listeleyebilirim.

Şimdiden yardımcı olacak arkadaşlara teşekkür ederim.

İyi akşamlar.
 

Ekli dosyalar

D

dost

Katılım
15 Mart 2005
Mesajlar
380
Excel Vers. ve Dili
Microsoft 365 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

Aşağıdaki kod ile çözdüm.

Ancak yöntemi beğenmedim :(
Üstadlardan da soruya ilgi gelmedi maalesef :(


C++: 
Sub Inv_List()

    Dim cn As Object, rs As Object
    Dim strSQL As String
    
    Dim i, j, y, sNr As Integer
    Dim iRow, lRow, lRow2 As Long
    Dim iSum, nSum As Double
    Dim sh As Worksheet
    Dim TmpWs, shVeri, c
    Dim fAddress As String
    
    Application.ScreenUpdating = False
    
    Sheets("Sonuç").Range("A1:E" & Rows.Count).ClearContents
        
    Set cn = CreateObject("ADODB.Connection")
    
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
                ";Extended Properties='Excel 12.0 Macro;HDR=YES'"
    

    strSQL = " SELECT [Veri$].[Firma Kodu] FROM [Veri$] " & _
             " INNER JOIN (SELECT [Firma Kodu] FROM [Veri$] " & _
             " WHERE [Fatura Tutari] >= 10000 GROUP BY [Firma Kodu]) As a " & _
             " ON a.[Firma Kodu] = [Veri$].[Firma Kodu] " & _
             " UNION " & _
             " SELECT [Firma Kodu] " & _
             " FROM [Veri$] " & _
             " GROUP BY [Firma Kodu] HAVING SUM([Fatura Tutari]) >=30000 "
            
   Set rs = cn.Execute(strSQL)
  
   Application.ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "TmpSh"
   Set TmpWs = ThisWorkbook.Sheets("TmpSh")
   TmpWs.Range("A1:E" & TmpWs.Rows.Count).ClearContents
  
   For j = 0 To rs.Fields.Count - 1
        TmpWs.Cells(1, j + 1) = rs.Fields(j).Name
   Next
    
   TmpWs.Range("A2").CopyFromRecordset rs
      
   lRow = TmpWs.Range("A" & Rows.Count).End(xlUp).Row
   lRow2 = Worksheets("Veri").Range("A" & Rows.Count).End(xlUp).Row
   iRow = 2:   iSum = 0:   sNr = 1
  
   Application.ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "shVeri"
   Set shVeri = ThisWorkbook.Sheets("shVeri")
  
   Worksheets("Veri").Cells.Copy
   shVeri.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
   Application.CutCopyMode = False
  
   shVeri.Range("A2:E" & lRow2).Sort [E2], xlDescending
   nSum = WorksheetFunction.Sum(shVeri.Range("E2:E" & lRow2)) * 70 / 100
 
   Worksheets("Sonuç").Range("A1:E1") = Array("S.No", "Firma Kodu", "Firma Tanimi", "Fatura Tarihi", "Fatura Tutari")
  
   For i = 2 To lRow
        With Worksheets("Veri").Range("B2:B" & lRow2)
            Set c = .Find(TmpWs.Range("A" & i), LookIn:=xlValues)
            If Not c Is Nothing Then
                fAddress = c.Address
                Do
                   Worksheets("Sonuç").Cells(iRow, 1) = sNr
                   sNr = sNr + 1
                   For y = 0 To 3
                        Worksheets("Sonuç").Cells(iRow, y + 2) = c.Offset(0, y)
                   Next y
                   iSum = iSum + c.Offset(0, 3)
                   Set c = .FindNext(c)
                   iRow = iRow + 1
                Loop While Not c Is Nothing And fAddress <> c.Address
            End If
        End With
  Next i
 
  If iSum < nSum Then
    For i = 2 To lRow2
          If iSum >= nSum Then Exit For
          Set c = TmpWs.Range("A2:A" & lRow2).Find(shVeri.Range("B" & i), LookIn:=xlValues)
          If c Is Nothing Then
            lRow = lRow + 1
            TmpWs.Range("A" & lRow) = shVeri.Range("B" & i)
            
            Worksheets("Sonuç").Cells(iRow, 1) = sNr
            sNr = sNr + 1
            For y = 2 To 5
                Worksheets("Sonuç").Cells(iRow, y) = shVeri.Cells(i, y)
            Next y
            iSum = iSum + shVeri.Cells(i, 5)
            iRow = iRow + 1
          
            With shVeri.Range("B" & i + 1 & ":B" & lRow2)
                Set c = .Find(shVeri.Range("B" & i), LookIn:=xlValues)
                If Not c Is Nothing Then
                    fAddress = c.Address
                    Do
                       Worksheets("Sonuç").Cells(iRow, 1) = sNr
                       sNr = sNr + 1
                       For y = 0 To 3
                            Worksheets("Sonuç").Cells(iRow, y + 2) = c.Offset(0, y)
                       Next y
                       iSum = iSum + c.Offset(0, 3)
                       Set c = .FindNext(c)
                       iRow = iRow + 1
                    Loop While Not c Is Nothing And fAddress <> c.Address
                End If
            End With
          End If
    Next i
  End If
  
  For Each sh In ThisWorkbook.Sheets
    If sh.Name = "TmpSh" Or sh.Name = "shVeri" Then
        Application.DisplayAlerts = False
        Application.ActiveWorkbook.Worksheets.Item(sh.Name).Delete
        Application.DisplayAlerts = True
    End If
  Next sh
 
  Set c = Nothing
  rs.Close
  Set rs = Nothing
 
  lRow = Worksheets("Sonuç").Range("A" & Rows.Count).End(xlUp).Row
  Worksheets("Sonuç").Range("B2:E" & lRow).Sort Key1:=[B2], Key2:=[D2]
 
  Application.ScreenUpdating = True
  
End Sub
 
D

dost

Katılım
15 Mart 2005
Mesajlar
380
Excel Vers. ve Dili
Microsoft 365 En 64 Bit
Altın Üyelik Bitiş Tarihi
20-03-2024
Merhaba,

Kodu biraz daha revize ettim.

Sadece kriter3'ü de SQL'e almak kaldı.

C++: 
Sub Inv_List2()

    Dim cn As Object, rs As Object
    Dim strSQL As String
    Dim sTableName As String
 
    Dim i, j, y, sNr As Integer
    Dim iRow, lRow, lRow2 As Long
    Dim iSum, nSum As Double
    Dim sh As Worksheet
    Dim TmpSh, shVeri, c
    Dim fAddress As String
    
    
    Application.ScreenUpdating = False
    
    Sheets("Sonuç").Range("A1:E" & Rows.Count).ClearContents
        
    Set cn = CreateObject("ADODB.Connection")
    
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
                ";Extended Properties='Excel 12.0 Macro;HDR=YES'"
    

    strSQL = " SELECT v.[Firma Kodu], v.[Firma Tanimi], v.[Fatura Tarihi], v.[Fatura Tutari] FROM [Veri$] v " & _
             " INNER JOIN " & _
             " (SELECT [Veri$].[Firma Kodu] FROM [Veri$] " & _
             " INNER JOIN (SELECT [Firma Kodu] FROM [Veri$] " & _
             " WHERE [Fatura Tutari] >= 10000 GROUP BY [Firma Kodu]) As a " & _
             " ON a.[Firma Kodu] = [Veri$].[Firma Kodu] " & _
             " UNION " & _
             " SELECT [Firma Kodu] " & _
             " FROM [Veri$] " & _
             " GROUP BY [Firma Kodu] HAVING SUM([Fatura Tutari]) >=30000) b " & _
             " ON b.[Firma Kodu] = v.[Firma Kodu] "
            
  
   Set rs = cn.Execute(strSQL)
      
   Worksheets("Sonuç").Range("A1:E1") = Array("S.No", "Firma Kodu", "Firma Tanimi", "Fatura Tarihi", "Fatura Tutari")
   Worksheets("Sonuç").Range("B2").CopyFromRecordset rs
    
   Application.ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "TmpSh"
   Set TmpSh = ThisWorkbook.Sheets("TmpSh")
  
   Worksheets("Veri").Cells.Copy
   TmpSh.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
   Application.CutCopyMode = False
  
   lRow2 = TmpSh.Range("B" & Rows.Count).End(xlUp).Row
   TmpSh.Range("A2:E" & lRow2).Sort [E2], xlDescending
   nSum = WorksheetFunction.Sum(TmpSh.Range("E2:E" & lRow2)) * 70 / 100
 
   lRow = Worksheets("Sonuç").Range("B" & Rows.Count).End(xlUp).Row
   lRow2 = Worksheets("Veri").Range("B" & Rows.Count).End(xlUp).Row
   iRow = Worksheets("Sonuç").Range("B" & Rows.Count).End(xlUp).Row + 1
   iSum = WorksheetFunction.Sum(Worksheets("Sonuç").Range("E2:E" & lRow))
 
   If iSum < nSum Then
        For i = 2 To lRow2
              If iSum >= nSum Then Exit For
              Set c = Worksheets("Sonuç").Range("B2:B" & lRow).Find(TmpSh.Range("B" & i), LookIn:=xlValues)
              If c Is Nothing Then
                    With TmpSh.Range("B" & i & ":B" & lRow2)
                        Set c = .Find(TmpSh.Range("B" & i), LookIn:=xlValues)
                        If Not c Is Nothing Then
                            fAddress = c.Address
                            Do
                               For y = 0 To 3
                                    Worksheets("Sonuç").Cells(iRow, y + 2) = c.Offset(0, y)
                               Next y
                               iSum = iSum + c.Offset(0, 3)
                               Set c = .FindNext(c)
                               iRow = iRow + 1
                            Loop While Not c Is Nothing And fAddress <> c.Address
                        End If
                    End With
              End If
        Next i
  End If
  
  For Each sh In ThisWorkbook.Sheets
    If sh.Name = "TmpSh" Then
        Application.DisplayAlerts = False
        Application.ActiveWorkbook.Worksheets.Item(sh.Name).Delete
        Application.DisplayAlerts = True
    End If
  Next sh
 
  Set c = Nothing
  rs.Close
  Set rs = Nothing
 
  lRow = Worksheets("Sonuç").Range("B" & Rows.Count).End(xlUp).Row
  Worksheets("Sonuç").Range("A2").Value = 1
  Worksheets("Sonuç").Cells(2, 1).AutoFill Destination:=Worksheets("Sonuç").Range("A2:A" & lRow), Type:=xlFillSeries
  Worksheets("Sonuç").Range("B2:E" & lRow).Sort Key1:=[B2], Key2:=[D2]
 
  Application.ScreenUpdating = True
  
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst