Skip to main content

AccessTr.neT

Kayıt Ol

 | Facebook ile Bağlan  | Twitter İle Bağlan | Google+ İle Bağlan

Döngü İle Excele Veri Aktarmak

lemoncher2
lemoncher2
Access Cevaplanmış Soruları
14
1483

Döngü İle Excele Veri Aktarmak

#7
userx
Uzman
userx
Bul
Uzman
Adı Soyadı:
Konum: -
Ofis Versiyonu: Ofis 2019 32 Bit
Son Oturumu: 11/04/2025,17:01
Yorumları: 601
Konuları: 2
Kayıt Tarihi: 24/08/2009
Teşekkür Puanı: 179
Sayın lemıncher2
Ekteki örneği inceler misin?
.rar 123_userx.rar (Dosya Boyutu: 33,21 KB | İndirme Sayısı: 4)
"Dünyayı fazla düşünme."
Cevapla
#8
lemoncher2
Destek Ekibi
lemoncher2
Bul
Destek
Adı Soyadı:
Konum: -
Ofis Versiyonu: -
Son Oturumu: 22/01/2023,00:30
Yorumları: 330
Konuları: 15
Kayıt Tarihi: 31/03/2020
Teşekkür Puanı: 90
(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.
Cevapla
#9
userx
Uzman
userx
Bul
Uzman
Adı Soyadı:
Konum: -
Ofis Versiyonu: Ofis 2019 32 Bit
Son Oturumu: 11/04/2025,17:01
Yorumları: 601
Konuları: 2
Kayıt Tarihi: 24/08/2009
Teşekkür Puanı: 179
Yani "Tablo1" den herhangi bir bilgi almayacak, "Alınan_Malzeme_Giriş" tablosundaki isimleri gruplayıp bu isimlere ait toplam değerleri mi alacak?
"Dünyayı fazla düşünme."
Cevapla
#10
lemoncher2
Destek Ekibi
lemoncher2
Bul
Destek
Adı Soyadı:
Konum: -
Ofis Versiyonu: -
Son Oturumu: 22/01/2023,00:30
Yorumları: 330
Konuları: 15
Kayıt Tarihi: 31/03/2020
Teşekkür Puanı: 90
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.
Son Düzenleme: 16/10/2021, 12:13, Düzenleyen: lemoncher2.
Cevapla
#11
lemoncher2
Destek Ekibi
lemoncher2
Bul
Destek
Adı Soyadı:
Konum: -
Ofis Versiyonu: -
Son Oturumu: 22/01/2023,00:30
Yorumları: 330
Konuları: 15
Kayıt Tarihi: 31/03/2020
Teşekkür Puanı: 90
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)
Cevapla
#12
lemoncher2
Destek Ekibi
lemoncher2
Bul
Destek
Adı Soyadı:
Konum: -
Ofis Versiyonu: -
Son Oturumu: 22/01/2023,00:30
Yorumları: 330
Konuları: 15
Kayıt Tarihi: 31/03/2020
Teşekkür Puanı: 90
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.
Son Düzenleme: 16/10/2021, 15:08, Düzenleyen: lemoncher2.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task