Döngü İle Excele Veri Aktarmak

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

userx

Private Sub Komut0_Click()
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")
    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.RunSQL ("SELECT Alinan_Malzeme_Giris.Malzeme_Adi, Tablo1.Malzeme_Seri_No, Alinan_Malzeme_Giris.Malzeme_Miktari, Tablo1.Alinan_ID" & vbCrLf & _
                "INTO tbl_ExceleVer FROM Tablo1 LEFT JOIN Alinan_Malzeme_Giris ON Tablo1.Alinan_ID = Alinan_Malzeme_Giris.Alinan_ID " & vbCrLf & _
                "WHERE (((Tablo1.Alinan_ID)=[Formlar]![Form1]![Metin1]));")
    rs2.MoveNext

Set rs = CurrentDb.OpenRecordset("tbl_ExceleVer")
        Do Until rs.EOF

Excl.Sheets(rs(0) & " " & rs(1)).Select
Excl.Range("A2").CopyFromRecordset rs
    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
    Set rs2 = Nothing
    DoCmd.SetWarnings True
  On Error GoTo a
DoCmd.RunSQL "DROP table tbl_ExceleVer;"
rs.Close
a: Exit Sub
Exit Sub
End Sub

Sayın lemoncher2 çözüm bulmuşsun ama bu şekilde de dener misin?
16/10/2021, 23:09

lemoncher2

(16/10/2021, 20:33)userx yazdı:
Private Sub Komut0_Click()
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")
    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.RunSQL ("SELECT Alinan_Malzeme_Giris.Malzeme_Adi, Tablo1.Malzeme_Seri_No, Alinan_Malzeme_Giris.Malzeme_Miktari, Tablo1.Alinan_ID" & vbCrLf & _
                "INTO tbl_ExceleVer FROM Tablo1 LEFT JOIN Alinan_Malzeme_Giris ON Tablo1.Alinan_ID = Alinan_Malzeme_Giris.Alinan_ID " & vbCrLf & _
                "WHERE (((Tablo1.Alinan_ID)=[Formlar]![Form1]![Metin1]));")
    rs2.MoveNext

Set rs = CurrentDb.OpenRecordset("tbl_ExceleVer")
        Do Until rs.EOF

Excl.Sheets(rs(0) & " " & rs(1)).Select
Excl.Range("A2").CopyFromRecordset rs
    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
    Set rs2 = Nothing
    DoCmd.SetWarnings True
  On Error GoTo a
DoCmd.RunSQL "DROP table tbl_ExceleVer;"
rs.Close
a: Exit Sub
Exit Sub
End Sub

Sayın lemoncher2 çözüm bulmuşsun ama bu şekilde de dener misin?


Hocam elinize sağlık döngü ile aktarımını gerçekleştirdim sanırım sizin kodu kullanacağım. Ben her eşleşme için tablo oluşturtmuştum siz tek tablo üzerinden halletmişsiniz. Teşekkür ederim.
16/10/2021, 23:15

userx

Kolay gelsin.
1 2 3