Excel'e Access'ten Şablona Veri Alma

1 2 3 4

Hocam birde dikkatimi yeni çekti siz giriş veya çıkış olarak tümünü eklemişsiniz ama ben aşağıdaki gibi kırmızı yerleri ekleme yaptım
Private Sub CommandButton21_Click()
Dim ra As Range
Dim SonVeri As Long

Dim baglan As New Connection
Dim rs As New Recordset
Dim Teslim As Worksheet
Dim rs2 As New Recordset
Dim a
a = "çıkış"
baglan.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\veri.accdb;"
rs2.Open "select DISTINCT kisi from giriscikis where ilce='" & Me.ComboBox5 & "' and yer='" & Me.ComboBox6 & "' ", baglan, adOpenKeyset, adLockPessimistic

sgl1 = " SELECT giriscikis.mlz_ad,'','','', Sum(giriscikis.mlz_miktar) AS TplMiktar, giriscikis.birim " & _
" FROM giriscikis " & _
" WHERE (((giriscikis.tarih) Between " & CLng(CDate(Me.TextBox16.Value)) & " And " & CLng(CDate(Me.TextBox17.Value)) & _
" ) AND ((giriscikis.ilce)='" & Me.ComboBox5 & "')AND ((giriscikis.durum)='" & a & "') AND ((giriscikis.yer)='" & Me.ComboBox6 & "'))" & _
" GROUP BY giriscikis.mlz_ad, giriscikis.birim"

rs.Open sgl1, baglan, adOpenKeyset, adLockPessimistic
Set Teslim = Worksheets("teslim_senedi")
Set ra = Teslim.Cells.Find(What:="Kalem Malzemeyi ", LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Debug.Print "rs.RecordCount", rs.RecordCount
SonVeri = ra.Row - 1
If SonVeri > 20 Then
Teslim.Rows(20 & ":" & SonVeri).Delete
End If

If rs.RecordCount > 12 Then
For X = 1 To rs.RecordCount - 12
Teslim.Rows(20).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
Teslim.Range("B20:E20").Merge (True)
Next X
End If
Teslim.Range("C5") = ""
Teslim.Range("B8:G19").ClearContents
Teslim.Range("C5") = CStr(Me.ComboBox5.Value) & " " & CStr(ComboBox6.Value)
Teslim.Range("f22").CopyFromRecordset rs2
Teslim.Range("B8").CopyFromRecordset rs
Teslim.Range("A8:G" & 7 + rs.RecordCount).Borders.LineStyle = xlContinuous

rs.Close
rs2.Close
baglan.Close
Set ra = Teslim.Cells.Find(What:="Kalem Malzemeyi ", LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

Debug.Print "ra ", ra.Row

End Sub

(03/03/2020, 11:09)erhan3479 yazdı: siz giriş veya çıkış olarak tümünü eklemişsiniz ama ben aşağıdaki gibi kırmızı yerleri ekleme yaptım

kastettiğiniz şeyi anlamadım sizin bahsettiğiniz kriterlere göre almıyor mu verileri?
sizin belirlediğiniz kriterler
1 - ilçe
2 - yer
3 -4: başlangıç ve bitiş tarihleri
sorgu kaynağına dikkat ederseniz zaten bu 4 kritere göre alıyor
" WHERE (((giriscikis.tarih) Between " & CLng(CDate(Me.TextBox16.Value)) & " And " & CLng(CDate(Me.TextBox17.Value)) & _
" ) AND ((giriscikis.ilce)='" & Me.ComboBox5 & "') AND ((giriscikis.yer)='" & Me.ComboBox6 & "'))"

aşağıdaki kodda teslim alan kişi de eklenmiştir

Dim ra As Range

Dim SonVeri As Long



Dim baglan As New Connection

Dim rs As New Recordset

Dim Teslim As Worksheet



baglan.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\veri.accdb;"



 sgl1 = " SELECT giriscikis.mlz_ad,'','','', Sum(giriscikis.mlz_miktar) AS TplMiktar, giriscikis.birim, giriscikis.kisi " & _

        " FROM giriscikis " & _

        " WHERE (((giriscikis.tarih) Between " & CLng(CDate(Me.TextBox16.Value)) & " And " & CLng(CDate(Me.TextBox17.Value)) & _

        " ) AND ((giriscikis.ilce)='" & Me.ComboBox5 & "') AND ((giriscikis.yer)='" & Me.ComboBox6 & "'))" & _

        " GROUP BY giriscikis.mlz_ad, giriscikis.birim, giriscikis.kisi"



rs.Open sgl1, baglan, adOpenKeyset, adLockPessimistic



    Set Teslim = Worksheets("teslim_senedi")

    Set ra = Teslim.Cells.Find(What:="Kalem Malzemeyi ", LookAt:=xlPart, SearchOrder:=xlByRows, _

             SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)



SonVeri = ra.Row - 1

If SonVeri > 20 Then Teslim.Rows(20 & ":" & SonVeri).Delete

Teslim.Range("C5") = ""

Teslim.Range("B8:G19").ClearContents



If rs.RecordCount = 0 Then

    rs.Close

    baglan.Close

    MsgBox "Uygun kayıt bulunamamıştır"

    Exit Sub

End If



Application.ScreenUpdating = False

rs.MoveFirst

Teslim.Range("F22").Value = rs(6)



If rs.RecordCount > 12 Then

    For X = 1 To rs.RecordCount - 12

        Teslim.Rows(20).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove

        Teslim.Range("B20:E20").Merge (True)

        Teslim.Range("B20:E20").HorizontalAlignment = xlLeft

        Teslim.Range("A20").Value = rs.RecordCount - X + 1

    Next X

End If



Teslim.Range("C5") = CStr(Me.ComboBox5.Value) & " " & CStr(ComboBox6.Value)



Teslim.Range("B8").CopyFromRecordset rs, , 6

Teslim.Range("A8:G" & 7 + rs.RecordCount).Borders.LineStyle = xlContinuous



rs.Close

baglan.Close

Application.ScreenUpdating = True

Hocam o sorunları ben yukarıda gönderdiğim kod ile hallettim. Teşekkürler bahsettiğiniz gibi bu programı Access de yapabilirmisiniz?

ücreti mukabilinde yaptırmak isterseniz İletişim bağlantısına tıklayarak yönetimle iletişime geçebilirsiniz ama onun dışında formun amacı sadece yardımcı olup yol göstermektir, baştan sona proje yapmıyoruz.

Teşekkürler ben Access te birşeyler yapmaya çalışayım takıldığımda umarım yardımcı olursunuz.

1 2 3 4

Excel'e Access'ten Şablona Veri Alma

erhan3479

berduş

erhan3479

berduş

erhan3479