Alt Alta Raporlama

[eskikentli]

Arkadaşlar merhaba,

Örnek dosya ekleyemiyorum. Test etme gibi bir durumunuz olamaz sanırım.
Excel sayfasında Y sütununda veritatabanından sorgulamak istediğim faturalara ait numaralar mevcut.
Bu faturaların kayıtlarını sorgularken evrak nosu alanı kriterimdir. Fakat copyrecorsed bölümünde faturlar raporlanırken ilk faturadan sonraki faturanın kayıtları ihemen ikinci satırdan başlayıp raporlanıyor ilk faturanın kayıtları sanki tek kayıtmış gibi görünüyor.
Evrak nosuna ait her faturanın alt alta raporlanmalarını nasıl sağlarım VT kriter alanım evrak nosu dur.
Renkli bölümde evrak nosu değiştikçe alt alta raporlama cümlesi yazmak gerek gibi. Bunu çözemedim.
Genel anlamda böyle bir sorum mevcuttur.Umarım anlatabilmişimdir.

Bu kod ile veriler sanki üst üste yazıyor gibi



Sheets("Kayıt").Range("A5:x65000").ClearContents

' ****
Set s1 = Sheets("Kayıt")
lrow = s1.Cells(Rows.Count, 25).End(xlUp).row
For i = 5 To lrow
For Each c In s1.Range("Y5:Y" & lrow)
If Not c.Value = "" Then
' *****

nSQL = ""
nSQL = nSQL & "Select tbFirma.sKodu, tbFirmaHareketi.nHareketID, tbFirmaHareketi.nFirmaID, tbFirmaHareketi.dteIslemTarihi, tbFirmaHareketi.dteValorTarihi, tbFirmaHareketi.sCariIslem, tbFirmaHareketi.fTip, " & vbCrLf
nSQL = nSQL & " tbFirmaHareketi.sEvrakNo, tbFirmaHareketi.sAciklama, tbFirmaHareketi.lCikisMiktar, tbFirmaHareketi.lCikisFiyat, tbFirmaHareketi.lGirisMiktar1, tbFirmaHareketi.lGirisMiktar2, " & vbCrLf
nSQL = nSQL & " tbFirmaHareketi.lGirisFiyat, tbFirmaHareketi.nKdvOrani, tbFirmaHareketi.nIskontoYuzdesi, tbFirmaHareketi.lMalHizmetTutari, tbFirmaHareketi.lBorcTutar, " & vbCrLf
nSQL = nSQL & "tbFirmaHareketi.lAlacakTutar, tbFirmaHareketi.lNot, tbFirmaHareketi.lNot2, tbFirmaHareketi.sKodu As sKodu1, tbFirmaHareketi.dteSonUpdateTarihi " & vbCrLf
nSQL = nSQL & "From tbFirma Inner Join tbFirmaHareketi On tbFirmaHareketi.nFirmaID = tbFirma.nFirmaID Where tbFirmaHareketi.sEvrakNo = '" & c.Value & "' "

Set cn = New ADODB.Connection
cn.Open "Driver={SQL Server};Server=" & ServerName & ";Database=" & DatabaseName & ";Uid=" & UserID & ";Pwd=" & Password & ";"
On Error Resume Next
rs.Open nSQL, cn, adOpenStatic

For iCols = 0 To rs.Fields.Count - 1
Worksheets("Kayıt").Cells(4, iCols + 1).Value = rs.Fields(iCols).Name
Next

If Not rs.EOF Then
s1.Cells(c.row, "A").CopyFromRecordset rs
rs.Close
End If
End If
Next c
Next

[SNNAY]

Deneyiniz;

Kod: Tümünü seç

Sheets("Kayıt").Range("A5:X65000").ClearContents

Dim lrow As Long
Dim startRow As Long
Dim rs As Object
Dim cn As Object
Dim c As Range
Dim nSQL As String

Set s1 = Sheets("Kayıt")
lrow = 5 ' İlk yazılacak satır

For Each c In s1.Range("Y5:Y" & s1.Cells(Rows.Count, 25).End(xlUp).Row)
    If Not c.Value = "" Then
        ' SQL sorgusunu oluştur
        nSQL = "SELECT tbFirma.sKodu, tbFirmaHareketi.nHareketID, tbFirmaHareketi.nFirmaID, " & _
               "tbFirmaHareketi.dteIslemTarihi, tbFirmaHareketi.dteValorTarihi, tbFirmaHareketi.sCariIslem, " & _
               "tbFirmaHareketi.fTip, tbFirmaHareketi.sEvrakNo, tbFirmaHareketi.sAciklama, " & _
               "tbFirmaHareketi.lCikisMiktar, tbFirmaHareketi.lCikisFiyat, tbFirmaHareketi.lGirisMiktar1, " & _
               "tbFirmaHareketi.lGirisMiktar2, tbFirmaHareketi.lGirisFiyat, tbFirmaHareketi.nKdvOrani, " & _
               "tbFirmaHareketi.nIskontoYuzdesi, tbFirmaHareketi.lMalHizmetTutari, tbFirmaHareketi.lBorcTutar, " & _
               "tbFirmaHareketi.lAlacakTutar, tbFirmaHareketi.lNot, tbFirmaHareketi.lNot2, " & _
               "tbFirmaHareketi.sKodu As sKodu1, tbFirmaHareketi.dteSonUpdateTarihi " & _
               "FROM tbFirma INNER JOIN tbFirmaHareketi " & _
               "ON tbFirmaHareketi.nFirmaID = tbFirma.nFirmaID " & _
               "WHERE tbFirmaHareketi.sEvrakNo = '" & c.Value & "' "

        ' Veritabanı bağlantısını aç
        Set cn = CreateObject("ADODB.Connection")
        cn.Open "Driver={SQL Server};Server=" & ServerName & ";Database=" & DatabaseName & ";Uid=" & UserID & ";Pwd=" & Password & ";"

        ' Verileri çek
        Set rs = CreateObject("ADODB.Recordset")
        rs.Open nSQL, cn, 1, 3 ' adOpenStatic ve adLockOptimistic

        ' Başlıkları yaz (sadece ilk seferde)
        If lrow = 5 Then
            For iCols = 0 To rs.Fields.Count - 1
                s1.Cells(4, iCols + 1).Value = rs.Fields(iCols).Name
            Next iCols
        End If

        ' Kayıtları yaz
        If Not rs.EOF Then
            startRow = lrow ' Başlangıç satırını belirle
            s1.Cells(lrow, "A").CopyFromRecordset rs
            lrow = s1.Cells(Rows.Count, "A").End(xlUp).Row + 1 ' Yeni kayıtlar için sonraki boş satırı bul
        End If

        ' Temizlik
        rs.Close
        cn.Close
        Set rs = Nothing
        Set cn = Nothing
    End If
Next c

[eskikentli]

Hay çok yaşayın.
Bu konuya dair hiç bir yanıt bulamamıştım. Öyle olunca gelip bakmıyordum. Bugün girdim ki bir ay olmuş yanıtınız.
İşte tam çözüm bu. Ellerin dert görmesin kardeşim.
Çok teşekkür ederim.