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 SubBu şekilde çözdüm sorunumu. Sayın hocalarım teşekkür ederim.
