• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İki tarih arasını sayfalardan aktarma

A

Ahmet Sami

Katılım
10 Kasım 2006
Mesajlar
399
Excel Vers. ve Dili
microsoft office 2007-2010-2013-2019-2021
İyi günler kıymetli abilerim gönderdiğim örnek dosyada bulunan herhangi İki Tarih Arasındaki Bilgilerin Mevcut Bulunan "Gider, Fatura, Muhtelif" Sayfalarından "Aktar" Sayfasına Aktarılması Gerekiyor yardımlarınız için şimdiden teşekkür ederim.
 

Ekli dosyalar

Kod: 
Sub aktar()
    Dim rs As Object, con$, strSQL$, tar1, tar2

    Sheets("AKTAR").Range("2:" & Rows.Count).ClearContents
    Set rs = CreateObject("ADODB.Recordset")

    tar1 = Replace(Format(Sheets("ANASAYFA").Range("H9").Value, "mm/dd/yyyy"), ".", "/")
    tar2 = Replace(Format(Sheets("ANASAYFA").Range("H10").Value, "mm/dd/yyyy"), ".", "/")

    con = "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & ThisWorkbook.FullName & _
          ";Extended Properties=""Excel 12.0;Hdr=YES"""

    strSQL = "SELECT * FROM " & _
             "( SELECT * FROM [FATURA$] UNION ALL " & _
             "  SELECT * FROM [MUHTELİF$] UNION ALL " & _
             "  SELECT * FROM [GİDER$] ) WHERE TARİH >=#" & _
             tar1 & "# AND TARİH <=#" & tar2 & "# ORDER BY TARİH"

    rs.Open strSQL, con, 1, 1

    Sheets("AKTAR").Range("A2").CopyFromRecordset rs

    rs.Close
End Sub
 
Veysel bey çok teşekkür ederim. Sağolun.
 
"( SELECT * FROM [FİRMA ÖDEME$] UNION ALL " & _
" SELECT * FROM [KİŞİ ÖDEME$] UNION ALL " & _
" SELECT * FROM [MAAŞ PRİM$] UNION ALL " & _
" SELECT * FROM [GİDER$] ) WHERE TARİH >=#" & _
tar1 & "# AND TARİH <=#" & tar2 & "# ORDER BY TARİH"
Veysel bey sizi yoruyorum ama kusuruma bakmayın sayfa ismi değiştirince kod
rs.Open strSQL, con, 1, 1
burda hata veriyor
 
Veysel bey normalde sayfalar gizli yani tarih olarak verileri gizli olan sayfalardan alıyor ondan dolayı bir sıkıntı olabilir mi
 
ceraeen' Alıntı:
baya uzun süre sonra yazıyorum ama :) bana bu dosya lazım yardımcı olma şansınız var mı ?
Genişletmek için tıkla ...
Ahmet Sami' Alıntı:
"( SELECT * FROM [FİRMA ÖDEME$] UNION ALL " & _
" SELECT * FROM [KİŞİ ÖDEME$] UNION ALL " & _
" SELECT * FROM [MAAŞ PRİM$] UNION ALL " & _
" SELECT * FROM [GİDER$] ) WHERE TARİH >=#" & _
tar1 & "# AND TARİH <=#" & tar2 & "# ORDER BY TARİH"
Veysel bey sizi yoruyorum ama kusuruma bakmayın sayfa ismi değiştirince kod
rs.Open strSQL, con, 1, 1
burda hata veriyor
Genişletmek için tıkla ...
Sn. Ahmet Sami Bey; Değiştirdiğiniz sayfa isminin kod içinde de değiştirmeniz gerekiyor, acep bunu mu atlıyorsunuz.
 
Tahsin bey evet aynı şekilde hem sayfa hemde kod içerisinde değiştiriyorum.
 
Merhaba,

Aşağıdaki şekilde kullanabilirsiniz.

C++: 
Sub aktar()
    Dim rs As Object, con$, strSQL$, tar1, tar2
    Dim s1Name, s2Name, s3Name As String

    Sheets("AKTAR").Range("2:" & Rows.Count).ClearContents
    Set rs = CreateObject("ADODB.Recordset")
   
    s1Name = Sheet1.Name
    s2Name = Sheet2.Name
    s3Name = Sheet3.Name

    tar1 = Replace(Format(Sheets("ANASAYFA").Range("H9").Value, "mm/dd/yyyy"), ".", "/")
    tar2 = Replace(Format(Sheets("ANASAYFA").Range("H10").Value, "mm/dd/yyyy"), ".", "/")

    con = "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & ThisWorkbook.FullName & _
          ";Extended Properties=""Excel 12.0;Hdr=YES"""

    strSQL = "SELECT * FROM " & _
             "( SELECT * FROM [" & s1Name & "$] UNION ALL " & _
             "  SELECT * FROM [" & s2Name & "$] UNION ALL " & _
             "  SELECT * FROM [" & s3Name & "$] ) WHERE TARİH >=#" & _
             tar1 & "# AND TARİH <=#" & tar2 & "# ORDER BY TARİH"

     rs.Open strSQL, con, 1, 1

    Sheets("AKTAR").Range("A2").CopyFromRecordset rs

    rs.Close
End Sub
 
Son düzenleme:
Merhaba,

Sorun sayfa başlıklarının 2.satırdan başlamış olması.

Kodu revize ettim. Sizin göndermiş olduğunuz dosyada çalıştı.

C++: 
Sub aktar()
    Dim rs As Object, con$, strSQL$, tar1, tar2
    Dim s1Name, s2Name, s3Name As String
    'Referance: Microsoft ActiveX data Object xxx Library

    Sheets("AKTAR").Range("2:" & Rows.Count).ClearContents
    Set rs = CreateObject("ADODB.Recordset")
    
    s1Name = "FİRMA ÖDEME"
    s2Name = "KİŞİ ÖDEME"
    s3Name = "GİDER"
    
 
    tar1 = Replace(Format(Sheets("ANASAYFA").Range("H9").Value, "mm/dd/yyyy"), ".", "/")
    tar2 = Replace(Format(Sheets("ANASAYFA").Range("H10").Value, "mm/dd/yyyy"), ".", "/")

    con = "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & ThisWorkbook.FullName & _
          ";Extended Properties=""Excel 12.0;Hdr=YES"""

    strSQL = "SELECT * FROM " & _
             "( SELECT * FROM [" & s1Name & "$A2:J] UNION ALL " & _
             "  SELECT * FROM [" & s2Name & "$A2:J] UNION ALL " & _
             "  SELECT * FROM [" & s3Name & "$A2:J] ) WHERE TARİH >=#" & _
             tar1 & "# AND TARİH <=#" & tar2 & "# ORDER BY TARİH"

   
    rs.Open strSQL, con, 1, 1

    Sheets("AKTAR").Range("A2").CopyFromRecordset rs

    rs.Close
    Set rs = Nothing
End Sub
 
Teşekkür ederim. Emeğinize elinize sağlık
 
Merhaba,

Ben kodda ufak bir değişiklik yaptım. Teşekkürü hak eden @veyselemre dir.

İyi çalışmalar.
 
Emeği geçen tüm üstadlarımıza teşekkür ederim.
Sayın dost gününüz hayır olsun,
Sizden bir istirhamım daha olacak aktarma işlemi tamam ama TL Dolar ve Euro sütunlarını aktarırken metin olarak aktardığı için AKTAR sayfasında toplam alamıyorum. Onu nasıl yapabilirim
 
Merhaba,

C++: 
Sub aktar()
    Dim rs As Object, con$, strSQL$, tar1, tar2
    Dim s1Name, s2Name, s3Name As String
    Dim lRow As Long, col As Byte
    Dim sumRng
    'Referance: Microsoft ActiveX data Object xxx Library

    Sheets("AKTAR").Range("2:" & Rows.Count).ClearContents
    Set rs = CreateObject("ADODB.Recordset")
    
    s1Name = "FİRMA ÖDEME"
    s2Name = "KİŞİ ÖDEME"
    s3Name = "GİDER"
    Sheets("AKTAR").Cells.Font.Bold = False
    Sheets("AKTAR").Columns("G:I").NumberFormat = "#,##0.00"
 
    tar1 = Replace(Format(Sheets("ANASAYFA").Range("H9").Value, "mm/dd/yyyy"), ".", "/")
    tar2 = Replace(Format(Sheets("ANASAYFA").Range("H10").Value, "mm/dd/yyyy"), ".", "/")

    con = "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & ThisWorkbook.FullName & _
          ";Extended Properties=""Excel 12.0;Hdr=YES"""

    strSQL = "SELECT * FROM " & _
             "( SELECT * FROM [" & s1Name & "$A2:J] UNION ALL " & _
             "  SELECT * FROM [" & s2Name & "$A2:J] UNION ALL " & _
             "  SELECT * FROM [" & s3Name & "$A2:J] ) WHERE TARİH >=#" & _
             tar1 & "# AND TARİH <=#" & tar2 & "# ORDER BY TARİH"

  
    rs.Open strSQL, con, 1, 1

    Sheets("AKTAR").Range("A2").CopyFromRecordset rs
    lRow = Sheets("AKTAR").Cells(Rows.Count, 1).End(xlUp).Row
    
    For col = 7 To 9
        sumRng = Sheets("AKTAR").Range(Sheets("AKTAR").Cells(2, col), Sheets("AKTAR").Cells(lRow, col))
        Sheets("AKTAR").Cells(lRow + 1, col) = Application.WorksheetFunction.Sum(sumRng)
    Next col
    
    Sheets("AKTAR").Cells(lRow + 1, "F") = "Toplam"
    Sheets("AKTAR").Cells(lRow + 1, 1).EntireRow.Font.Bold = True

    rs.Close
    Set rs = Nothing
    MsgBox "Veriler AKTAR sayfasına aktarılmıştır..."
    
    Worksheets("AKTAR").Visible = True
    Worksheets("AKTAR").Activate
    Sheets("AKTAR").Range("A1").Select
    
End Sub
 
Üstadım yine metin hücresi olarak atıyor ve toplama yapmıyor. Ancak hücrenin içerisine girip çıkarsam toplama yapıyor.
 
Excel dosyanızı tekrar ekler misiniz.
 
Buyurun sayın dost. Kusurumuza bakmayın rahatsızdım bir kaç gün yattım size dönemedim.
 

Ekli dosyalar

Merhaba,

Göndermiş olduğunuz dosyaya kodu kopyaladım.
Sorunsuz çalıştı.

Dosya ektedir.
 

Ekli dosyalar

Çok teşekkür ederim. Hakkınızı helal edin sizi yordum sağolun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst