AccessTr.neTMicrosoft AccessAccess Cevaplanmış Soruları

Döngü İle Excele Veri Aktarmak

1 2 3
16/10/2021, 03:20

userx

Sayın lemıncher2
Ekteki örneği inceler misin?
16/10/2021, 10:29

lemoncher2

(16/10/2021, 03:20)userx yazdı: Sayın lemıncher2
Ekteki örneği inceler misin?

Hocam Sayfa isimleri tablo1 den alıyor. Sayfa isimlerini "Alınan_Malzeme_Giriş" deki Malzeme_Adı Sütunundaki değerleri alması gerekiyor.

Tablo1 verilerini aktardığımızda sadece Alınan_ID değeri eşleşen 1 değeri getiriyor hepsini getirmesi gerekmekte.
16/10/2021, 11:56

userx

Yani "Tablo1" den herhangi bir bilgi almayacak, "Alınan_Malzeme_Giriş" tablosundaki isimleri gruplayıp bu isimlere ait toplam değerleri mi alacak?
16/10/2021, 12:13

lemoncher2

Kod:
On Error Resume Next
  DoCmd.SetWarnings False
'      If MsgBox("Bilgileriniz Excele Aktarılsın mı?", vbCritical + vbYesNo + vbDefaultButton1, "UYARI") = vbNo Then Exit Sub
  '      MsgBox "Aktarma İşlemi BİP sesini Duyana Kadar Devam Edecektir Excel Açıldıktan Sonra Hücrelere Tıklarsanız Eksik veya Hatalı Aktarabilir. Bilgisayarınızın Sesi Açık Olduğundan Emin Olunuz.", vbDefaultButton1, "UYARI!!!"

    Dim rs As Recordset
Dim rs2 As Recordset
    Dim KTP As Excel.Workbook
    Dim SYF As Excel.Worksheet
   
    Set Excl = New Excel.Application
    With Excl
      .Application.Visible = True
      .UserControl = True

    End With
        Set KTP = Excl.Workbooks.Open(CurrentProject.Path & "\deneme.xlsx")
        Set rs2 = CurrentDb.OpenRecordset("Alinan_Malzeme_Giris")
        Set rs = CurrentDb.OpenRecordset("SELECT Tablo1.Harcanan_ID, Tablo1.Malzeme_Adi, Tablo1.Malzeme_Seri_No, Tablo1.Alinan_ID, Alinan_Malzeme_Giris.Malzeme_Grubu, Alinan_Malzeme_Giris.Malzeme_Adi" & vbCrLf & _
"FROM Tablo1 INNER JOIN Alinan_Malzeme_Giris ON Tablo1.Alinan_ID = Alinan_Malzeme_Giris.Alinan_ID;", dbOpenDynaset)

'Set rs = CurrentDb.OpenRecordset("Sorgu1")


Dim ş
ş = 1
Do Until rs2.EOF
 
        SyfAdi = rs2(1) & " " & rs2(2)
            SyfAdiTmp = SyfAdi
            SyfNo = 0
            Do While WorksheetExists(SyfAdiTmp, KTP) = True
            SyfNo = SyfNo + 1
            SyfAdiTmp = SyfAdi & IIf(SyfNo = 0, "", "(" & SyfNo & ")")
            Loop
            Excl.Sheets.Add.Name = SyfAdiTmp
            rs2.MoveNext
Me.Metin1 = rs2(0)
Loop
rs2.Close
         
  With SyfAdiTmp
     
Dim i
i = 1
Do Until rs.EOF
Excl.Sheets(rs(4) & " " & rs(5)).Select

        Excl.Range("A1") = "Malzeme Adı":  Excl.Range("A" & i).Value = rs(0)
        Excl.Range("B1") = "Seri No":      Excl.Range("B" & i).Value = rs(1)
        Excl.Range("C1") = "Miktar":        Excl.Range("C" & i).Value = rs(2)
        Excl.Range("D1") = "ALINANID":        Excl.Range("D" & i).Value = rs(3)

i = i + 1
        rs.MoveNext
    Loop
        rs.Close

End With

  Excl.Visible = True

    Set MyRecordset = Nothing
    Set Excl = Nothing
    Set KTP = Nothing
    Set SYF = Nothing
    Set rs = Nothing
    DoCmd.SetWarnings True
   
Exit Sub
End

Bu kodu çalıştırdığınızda ne yapmak istediğim daha anlaşılır olur sanırım.
Kodu bu şekilde düzenledim sonuca biraz daha yaklaştım tek sorun. Aktardığında kaydın bulunduğu sıraya göre aktarım gerçekleştiriyor arada boş satırlar olmaması gerekiyor.
16/10/2021, 13:33

lemoncher2

Kısaca şöyle özetliyim
Alınan_Malzeme_Giriş.Malzeme_Adı buradaki verilere ait Excelde sayfalar oluşturacağız

Bu oluşturmuş olduğumuz sayfalara Tablo1 de karşılık gelen verileri aktaracağız.

(Karşılık gelen veriler"Tablo1" her iki tablodada ilişkili olan Alınan_ID değeleri ile aynı olan değerler ilgili sayfalarına aktarılmış olacak)
16/10/2021, 15:08

lemoncher2

Kod:
On Error Resume Next
  DoCmd.SetWarnings False

Dim rs As Recordset
Dim rs2 As Recordset
Dim KTP As Excel.Workbook
Dim SYF As Excel.Worksheet
   
    Set Excl = New Excel.Application
    With Excl
      .Application.Visible = True
      .UserControl = True

    End With
        Excl.DisplayAlerts = False
        Set KTP = Excl.Workbooks.Add
        KTP.SaveAs (CurrentProject.Path & "\deneme3.xlsx")
               
        Set rs2 = CurrentDb.OpenRecordset("Alinan_Malzeme_Giris")



Dim ş
Dim ğ
ğ = 1
ş = 1
Do Until rs2.EOF
 
        SyfAdi = rs2(1) & " " & rs2(2)
            SyfAdiTmp = SyfAdi
            SyfNo = 0
            Do While WorksheetExists(SyfAdiTmp, KTP) = True
            SyfNo = SyfNo + 1
            SyfAdiTmp = SyfAdi & IIf(SyfNo = 0, "", "(" & SyfNo & ")")
            Loop
            Excl.Sheets.Add.Name = SyfAdiTmp
           
           
            Excl.Range("A1") = "Malzeme Adı"
            Excl.Range("B1") = "Seri No"
            Excl.Range("C1") = "Miktar"
            Excl.Range("D1") = "ALINANID"
         
Me.Metin1 = rs2(0)
DoCmd.SetWarnings False
DoCmd.RunSQL ("SELECT Tablo1.Harcanan_ID, Tablo1.Malzeme_Adi, Tablo1.Malzeme_Seri_No, Tablo1.Alinan_ID, Alinan_Malzeme_Giris.Malzeme_Grubu, Alinan_Malzeme_Giris.Malzeme_Adi INTO gecici_malzeme" & ğ & " FROM Tablo1 INNER JOIN Alinan_Malzeme_Giris ON Tablo1.Alinan_ID = Alinan_Malzeme_Giris.Alinan_ID WHERE (((Tablo1.Alinan_ID)=[Formlar]![Form1]![Metin1]));")
DoCmd.SetWarnings True
  ğ = ğ + 1


  rs2.MoveNext
Dim i
i = 1


Set rs = CurrentDb.OpenRecordset("gecici_malzeme" & ğ - 1)

Do Until rs.EOF

Excl.Sheets(rs(4) & " " & rs(5)).Select



              Excl.Range("A" & i + 1).Value = rs(0)
              Excl.Range("B" & i + 1).Value = rs(1)
              Excl.Range("C" & i + 1).Value = rs(2)
              Excl.Range("D" & i + 1).Value = rs(3)
i = i + 1


rs.MoveNext

    Loop
    rs.Close

  Loop
rs2.Close
 
 
    Excl.Visible = True

    Set MyRecordset = Nothing
    Set Excl = Nothing
    Set KTP = Nothing
    Set SYF = Nothing
    Set rs = Nothing
    DoCmd.SetWarnings True
 

 
  On Error GoTo a
Dim ç
ç = 1

Do Until pp

DoCmd.DeleteObject acTable, "gecici_malzeme" & ç
        ç = ç + 1

    Loop
rs.Close
a: Exit Sub
 

Exit Sub


Bu şekilde çözdüm sorunumu. Sayın hocalarım teşekkür ederim.
1 2 3