• DİKKAT

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

Veri aktarma (Sayfa Aktarımı)

R

RALKAN

Katılım
3 Şubat 2007
Mesajlar
309
Excel Vers. ve Dili
excel 2007 / excel 2010
Merhaba arkadaşlar ,

Foruma eklenen kod yardımı ile aynı klasör içerisinde belirtilen farklı bir dosyadan bir sayfayı başka bir dosyaya aktarım yapıyorum.

Aşağıda ki konularda yardımınıza ihtiyacım bulunmakta.

1. Aktarımı yapılan sayfadaki butonlarda kopyalanıyor, butonlar gelmeden aktarılması
2. Aktarım yapılan sayfanın örnekte detayını belirttiğim P sütununda ki değerleri alacaklarımızı takip için kullanıyorum , bu alanı kriter vererek sıfırdan büyük olanları ve büyükten küçüğe sıralama yaparak aktarımın yapılması için ek kod düzenlenmesine için yardım rica ediyorum.

Not:
Sıfıra eşit ve sıfırdan küçük olanların aktarılmamasının sağlanması
 

Ekli dosyalar

Dener misiniz ?
Kod: 
Sub VERİLERİ_AKTAR()
    Dim Dosya_Yolu As String, Asıl_Dosya As Workbook, Kaynak_Dosya As Workbook
    Dim evn As Byte
    Application.ScreenUpdating = False
    Set Asıl_Dosya = ThisWorkbook
    Asıl_Dosya.ActiveSheet.[A:U].ClearContents
    Dosya_Yolu = ThisWorkbook.Path & "\"
    Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu & "ALACAK-BORC.xls", False, False)
    Kaynak_Dosya.ActiveSheet.Cells.Copy
    Asıl_Dosya.Activate
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select
    Kaynak_Dosya.Close True
    Set Kaynak_Dosya = Nothing
    On Error Resume Next
    For evn = 1 To ActiveSheet.Shapes.Count
    If ActiveSheet.Shapes(evn).Name Like "Button*" Then
    ActiveSheet.Shapes(evn).Delete
    End If
    Next 
    Set Asıl_Dosya = Nothing
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
dosya_yolu=vbnullstring:Asıl_dosya=vbnullstring:kaynak_dosya=vbnullstring:evn=empty
End Sub
 
Tarkan VURAL' Alıntı:
Dener misiniz ?
Kod: 
Sub VERİLERİ_AKTAR()
    Dim Dosya_Yolu As String, Asıl_Dosya As Workbook, Kaynak_Dosya As Workbook
    Dim evn As Byte
    Application.ScreenUpdating = False
    Set Asıl_Dosya = ThisWorkbook
    Asıl_Dosya.ActiveSheet.[A:U].ClearContents
    Dosya_Yolu = ThisWorkbook.Path & "\"
    Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu & "ALACAK-BORC.xls", False, False)
    Kaynak_Dosya.ActiveSheet.Cells.Copy
    Asıl_Dosya.Activate
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select
    Kaynak_Dosya.Close True
    Set Kaynak_Dosya = Nothing
    On Error Resume Next
    For evn = 1 To ActiveSheet.Shapes.Count
    If ActiveSheet.Shapes(evn).Name Like "Button*" Then
    ActiveSheet.Shapes(evn).Delete
    End If
    Next 
    Set Asıl_Dosya = Nothing
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
dosya_yolu=vbnullstring:Asıl_dosya=vbnullstring:kaynak_dosya=vbnullstring:evn=empty
End Sub
Genişletmek için tıkla ...

Sayın Tarkan Vural ,

İlgine çok teşekkür ederim , aktarım yapıldığında veri aktar butonu kayboluyor ve verilerin alındığı sayfadaki aktar butonu geliyor.Ayrıca P sütunundaki değerlerin sıfırdan büyük olanların aktarılmasını rica etmiştim büyükten küçüğe sıralayarak o işlem görülmüyor.
 
Yaptığınız işlemi anlamadım, tereddütte kaldım. Anlasam daha farklı bir çözüm önerecektim.
İstenen şey bir dosya içindeki sıfırdan büyük değere sahip kriterli verileri başka bir dosya üzerine mi almak ? Detaylı izah edebilir misiniz ?
 
Tarkan VURAL' Alıntı:
Yaptığınız işlemi anlamadım, tereddütte kaldım. Anlasam daha farklı bir çözüm önerecektim.
İstenen şey bir dosya içindeki sıfırdan büyük değere sahip kriterli verileri başka bir dosya üzerine mi almak ? Detaylı izah edebilir misiniz ?
Genişletmek için tıkla ...

Sayın Tarkan Vural ,

Görüleceği üzere A sütunu Cari kodlar P sütunu ise alacak toplamım ,alacak toplamı sıfırdan büyük olanları büyükten küçüğe sıralayarak tüm alanları başka bir dosyaya almak istiyorum.

Umarım açıklayıcı olmuştur, yorgunluk verdim kusuruma bakmayınız lütfen.
 
Diğer dosya da aynı formatta mı ? Tamamen aynı mı ? Alacak-Borc.xls' den bahsediyorum ?
 
Şöyle yapalım. Bene ALACAK_BORC dosyanızı sıfırladım ve boşalttım.
Aşağıdaki kodlara göre ALACAKLAR dosyasındaki verileri aynı klasör içindeki kapalı olan ALACAK_BORC dosyasına aktarıyor. Aktarımdan sonra dossyayı açıp inceleyiniz.
Kod: 
Option Explicit

Sub VERİLERİ_AKTAR()
Dim con As Object, rs As Object
Dim a As Long
Set con = CreateObject("adodb.connection")
con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\ALACAK_BORC.xls;extended properties=""excel 8.0;hdr=yes"""
Set rs = CreateObject("adodb.recordset")
    With rs
        .Open "select * from [Sayfa1$]", con, 1, 3
            For a = 4 To Sheets("sayfa1").Range("a4").End(4).Row
                .addnew
                If Sheets("sayfa1").Cells(a, "p").Value <> 0 Then
                    rs.fields(0).Value = Sheets("sayfa1").Cells(a, 1).Value
                    rs.fields(1).Value = Sheets("sayfa1").Cells(a, 2).Value
                    rs.fields(2).Value = Sheets("sayfa1").Cells(a, 3).Value
                    rs.fields(3).Value = Sheets("sayfa1").Cells(a, 4).Value
                    rs.fields(4).Value = Sheets("sayfa1").Cells(a, 5).Value
                    rs.fields(5).Value = Sheets("sayfa1").Cells(a, 6).Value
                    rs.fields(6).Value = Sheets("sayfa1").Cells(a, 7).Value
                    rs.fields(7).Value = Sheets("sayfa1").Cells(a, 8).Value
                    rs.fields(8).Value = Sheets("sayfa1").Cells(a, 9).Value
                    rs.fields(9).Value = Sheets("sayfa1").Cells(a, 10).Value
                    rs.fields(10).Value = Sheets("sayfa1").Cells(a, 11).Value
                    rs.fields(11).Value = Sheets("sayfa1").Cells(a, 12).Value
                    rs.fields(12).Value = Sheets("sayfa1").Cells(a, 13).Value
                    rs.fields(13).Value = Sheets("sayfa1").Cells(a, 14).Value
                    rs.fields(14).Value = Sheets("sayfa1").Cells(a, 15).Value
                    rs.fields(15).Value = Sheets("sayfa1").Cells(a, 16).Value
                    rs.fields(16).Value = Sheets("sayfa1").Cells(a, 17).Value
                    rs.fields(17).Value = Sheets("sayfa1").Cells(a, 18).Value
                    rs.fields(18).Value = Sheets("sayfa1").Cells(a, 19).Value
                    rs.fields(19).Value = Sheets("sayfa1").Cells(a, 20).Value
                    rs.fields(20).Value = Sheets("sayfa1").Cells(a, 21).Value
                End If
                .Update
            Next a
    End With
Set con = Nothing: Set rs = Nothing
a = Empty
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Örnekleri de ekleyeyim.
 

Ekli dosyalar

Sayın Tarkan Vural ,

Gerekli incelemeleri yapıp size geri dönüş yapacağım, teşekkür ederim

İyi Akşamlar
 
Tarkan VURAL' Alıntı:
Şöyle yapalım. Bene ALACAK_BORC dosyanızı sıfırladım ve boşalttım.
Aşağıdaki kodlara göre ALACAKLAR dosyasındaki verileri aynı klasör içindeki kapalı olan ALACAK_BORC dosyasına aktarıyor. Aktarımdan sonra dossyayı açıp inceleyiniz.
Kod: 
Option Explicit

Sub VERİLERİ_AKTAR()
Dim con As Object, rs As Object
Dim a As Long
Set con = CreateObject("adodb.connection")
con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\ALACAK_BORC.xls;extended properties=""excel 8.0;hdr=yes"""
Set rs = CreateObject("adodb.recordset")
    With rs
        .Open "select * from [Sayfa1$]", con, 1, 3
            For a = 4 To Sheets("sayfa1").Range("a4").End(4).Row
                .addnew
                If Sheets("sayfa1").Cells(a, "p").Value <> 0 Then
                    rs.fields(0).Value = Sheets("sayfa1").Cells(a, 1).Value
                    rs.fields(1).Value = Sheets("sayfa1").Cells(a, 2).Value
                    rs.fields(2).Value = Sheets("sayfa1").Cells(a, 3).Value
                    rs.fields(3).Value = Sheets("sayfa1").Cells(a, 4).Value
                    rs.fields(4).Value = Sheets("sayfa1").Cells(a, 5).Value
                    rs.fields(5).Value = Sheets("sayfa1").Cells(a, 6).Value
                    rs.fields(6).Value = Sheets("sayfa1").Cells(a, 7).Value
                    rs.fields(7).Value = Sheets("sayfa1").Cells(a, 8).Value
                    rs.fields(8).Value = Sheets("sayfa1").Cells(a, 9).Value
                    rs.fields(9).Value = Sheets("sayfa1").Cells(a, 10).Value
                    rs.fields(10).Value = Sheets("sayfa1").Cells(a, 11).Value
                    rs.fields(11).Value = Sheets("sayfa1").Cells(a, 12).Value
                    rs.fields(12).Value = Sheets("sayfa1").Cells(a, 13).Value
                    rs.fields(13).Value = Sheets("sayfa1").Cells(a, 14).Value
                    rs.fields(14).Value = Sheets("sayfa1").Cells(a, 15).Value
                    rs.fields(15).Value = Sheets("sayfa1").Cells(a, 16).Value
                    rs.fields(16).Value = Sheets("sayfa1").Cells(a, 17).Value
                    rs.fields(17).Value = Sheets("sayfa1").Cells(a, 18).Value
                    rs.fields(18).Value = Sheets("sayfa1").Cells(a, 19).Value
                    rs.fields(19).Value = Sheets("sayfa1").Cells(a, 20).Value
                    rs.fields(20).Value = Sheets("sayfa1").Cells(a, 21).Value
                End If
                .Update
            Next a
    End With
Set con = Nothing: Set rs = Nothing
a = Empty
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Örnekleri de ekleyeyim.
Genişletmek için tıkla ...


Sayın Tarkan Vural ,

İşlemi gerçekleştiremedim ,Verilerin alındığı yer "Alacak_Borç" dosyasının "Alacaklar" sayfası belki bu neden gerçekleşmemiş olabilir mi acaba tekrar bakabilirmisiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst