+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Access (https://accesstr.net/forum-microsoft-access.html)
+--- Forum: Access Cevaplanmış Soruları (https://accesstr.net/forum-access-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Döngü İle Excele Veri Aktarmak (/konu-dongu-ile-excele-veri-aktarmak.html)
RE: Döngü İle Excele Veri Aktarmak - userx - 16/10/2021
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?
RE: Döngü İle Excele Veri Aktarmak - lemoncher2 - 16/10/2021
(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.
RE: Döngü İle Excele Veri Aktarmak - userx - 16/10/2021
Kolay gelsin.