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
EndKodu 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.
