baska dosyadan veri alan macro

eneskus · 11 Haziran 2012

Arkadaşlar aşağıdaki kod aynı excel dosyasında veri sayfasından verileri süzerek aktarmakta. ( kodları yazan arkadaştan allah razı olsun)
Benim yapmak isteyipte yapamadığım
1- Aynı excel dosyasında veri sayfasından değilde kapalı olan veri.xls dosyasında veri sayfasından verileri süzerek alması.
2. Bu kod sayfa aktif olduğunda çalışmakta ben excel dosyasını her açtığımda makro güvenlik uyarısına evet dedikten sonra hemen çalışarak verileri güncellemesini sağlamam gerekmekte.

ADO ile uğraştım ama beceremedim yardım ederseniz cok memnun olurum.

Kod:

Private Sub Worksheet_Activate()
Dim c As Range, sat As Long, ilkadres As Variant
Range("A5:AU" & Rows.Count).ClearContents
sat = 5
With Sheets("VERİ").Range("R:R")
Set c = .Find(ActiveSheet.Name, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
ilkadres = c.Address
Do
Cells(sat, "A") = Sheets("VERİ").Cells(c.Row, "A")
Cells(sat, "B") = Sheets("VERİ").Cells(c.Row, "B")
Cells(sat, "C") = Sheets("VERİ").Cells(c.Row, "C")
Cells(sat, "D") = Sheets("VERİ").Cells(c.Row, "D")
Cells(sat, "E") = Sheets("VERİ").Cells(c.Row, "E")
Cells(sat, "F") = Sheets("VERİ").Cells(c.Row, "F")
Cells(sat, "G") = Sheets("VERİ").Cells(c.Row, "G")
Cells(sat, "H") = Sheets("VERİ").Cells(c.Row, "H")
Cells(sat, "I") = Sheets("VERİ").Cells(c.Row, "I")
Cells(sat, "J") = Sheets("VERİ").Cells(c.Row, "J")
Cells(sat, "K") = Sheets("VERİ").Cells(c.Row, "K")
Cells(sat, "L") = Sheets("VERİ").Cells(c.Row, "L")
Cells(sat, "M") = Sheets("VERİ").Cells(c.Row, "M")
Cells(sat, "N") = Sheets("VERİ").Cells(c.Row, "N")
Cells(sat, "O") = Sheets("VERİ").Cells(c.Row, "O")
Cells(sat, "P") = Sheets("VERİ").Cells(c.Row, "P")
Cells(sat, "Q") = Sheets("VERİ").Cells(c.Row, "Q")
Cells(sat, "R") = Sheets("VERİ").Cells(c.Row, "R")
Cells(sat, "S") = Sheets("VERİ").Cells(c.Row, "S")
Cells(sat, "T") = Sheets("VERİ").Cells(c.Row, "T")
Cells(sat, "U") = Sheets("VERİ").Cells(c.Row, "U")
Cells(sat, "V") = Sheets("VERİ").Cells(c.Row, "V")
Cells(sat, "W") = Sheets("VERİ").Cells(c.Row, "W")
Cells(sat, "X") = Sheets("VERİ").Cells(c.Row, "X")
Cells(sat, "Y") = Sheets("VERİ").Cells(c.Row, "Y")
Cells(sat, "Z") = Sheets("VERİ").Cells(c.Row, "Z")
Cells(sat, "AA") = Sheets("VERİ").Cells(c.Row, "AA")
Cells(sat, "AB") = Sheets("VERİ").Cells(c.Row, "AB")
Cells(sat, "AC") = Sheets("VERİ").Cells(c.Row, "AC")
Cells(sat, "AD") = Sheets("VERİ").Cells(c.Row, "AD")
Cells(sat, "AE") = Sheets("VERİ").Cells(c.Row, "AE")
Cells(sat, "AF") = Sheets("VERİ").Cells(c.Row, "AF")
Cells(sat, "AG") = Sheets("VERİ").Cells(c.Row, "AG")
Cells(sat, "AH") = Sheets("VERİ").Cells(c.Row, "AH")
Cells(sat, "AI") = Sheets("VERİ").Cells(c.Row, "AI")
Cells(sat, "AJ") = Sheets("VERİ").Cells(c.Row, "AJ")
Cells(sat, "AK") = Sheets("VERİ").Cells(c.Row, "AK")
Cells(sat, "AL") = Sheets("VERİ").Cells(c.Row, "AL")
Cells(sat, "AM") = Sheets("VERİ").Cells(c.Row, "AM")
Cells(sat, "AN") = Sheets("VERİ").Cells(c.Row, "AN")
Cells(sat, "AO") = Sheets("VERİ").Cells(c.Row, "AO")
Cells(sat, "AP") = Sheets("VERİ").Cells(c.Row, "AP")
Cells(sat, "AQ") = Sheets("VERİ").Cells(c.Row, "AQ")
Cells(sat, "AR") = Sheets("VERİ").Cells(c.Row, "AR")
Cells(sat, "AS") = Sheets("VERİ").Cells(c.Row, "AS")
Cells(sat, "AT") = Sheets("VERİ").Cells(c.Row, "AT")
Cells(sat, "AU") = Sheets("VERİ").Cells(c.Row, "AU")
sat = sat + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> ilkadres
End If
End With
End Sub

serqet · 11 Haziran 2012

Türkçe nasıl katledilir.

eneskus · 20 Haziran 2012

serqet' Alıntı:
Türkçe nasıl katledilir.

bundan başka tek cevap yok buda cevap değil.

eneskus · 21 Haziran 2012

Arkadaşlar neden kimse bakmıyor.
Bir hatam varsa bari hatamı söleyinde düzelteyim.

Korhan Ayhan · 21 Haziran 2012

Merhaba,

Kelimeleri yazarken yazım kurallarına azami özen gösterebilirseniz sevinirim.

Aşağıdaki kodu deneyin.

Kod:

Private Sub Worksheet_Activate()
    Dim c As Range, sat As Long, ilkadres As Variant
    Dim Uygulama As Application, Dosya As Workbook
 
    Range("A5:AU" & Rows.Count).ClearContents
    sat = 5
 
    Set Uygulama = CreateObject("Excel.Application")
    Set Dosya = Uygulama.Workbooks.Open(ThisWorkbook.Path & "\VERİ.xlsm")
    Uygulama.Visible = False
 
    With Dosya.Sheets("VERİ").Range("R:R")
        Set c = .Find(ActiveSheet.Name, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                Range("A" & sat & ":AU" & sat).Value = dosya.Sheets("VERİ").Range("A" & c.Row & ":AU" & c.Row).Value

                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
 
    Uygulama.Quit
End Sub

eneskus · 21 Haziran 2012

Korhan Ayhan' Alıntı:

Merhaba,

Kelimeleri yazarken yazım kurallarına azami özen gösterebilirseniz sevinirim.

Aşağıdaki kodu deneyin.

Kod:

Private Sub Worksheet_Activate()
    Dim c As Range, sat As Long, ilkadres As Variant
    Dim Uygulama As Application, Dosya As Workbook
    
    Range("A5:AU" & Rows.Count).ClearContents
    sat = 5
    
    Set Uygulama = CreateObject("Excel.Application")
    Set Dosya = Uygulama.Workbooks.Open(ThisWorkbook.Path & "\VERİ.xlsm")
    Uygulama.Visible = False
    
    With Dosya.Sheets("VERİ").Range("R:R")
        Set c = .Find(ActiveSheet.Name, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                Cells(sat, "A") = Dosya.Sheets("VERİ").Cells(c.Row, "A")
                Cells(sat, "B") = Dosya.Sheets("VERİ").Cells(c.Row, "B")
                Cells(sat, "C") = Dosya.Sheets("VERİ").Cells(c.Row, "C")
                Cells(sat, "D") = Dosya.Sheets("VERİ").Cells(c.Row, "D")
                Cells(sat, "E") = Dosya.Sheets("VERİ").Cells(c.Row, "E")
                Cells(sat, "F") = Dosya.Sheets("VERİ").Cells(c.Row, "F")
                Cells(sat, "G") = Dosya.Sheets("VERİ").Cells(c.Row, "G")
                Cells(sat, "H") = Dosya.Sheets("VERİ").Cells(c.Row, "H")
                Cells(sat, "I") = Dosya.Sheets("VERİ").Cells(c.Row, "I")
                Cells(sat, "J") = Dosya.Sheets("VERİ").Cells(c.Row, "J")
                Cells(sat, "K") = Dosya.Sheets("VERİ").Cells(c.Row, "K")
                Cells(sat, "L") = Dosya.Sheets("VERİ").Cells(c.Row, "L")
                Cells(sat, "M") = Dosya.Sheets("VERİ").Cells(c.Row, "M")
                Cells(sat, "N") = Dosya.Sheets("VERİ").Cells(c.Row, "N")
                Cells(sat, "O") = Dosya.Sheets("VERİ").Cells(c.Row, "O")
                Cells(sat, "P") = Dosya.Sheets("VERİ").Cells(c.Row, "P")
                Cells(sat, "Q") = Dosya.Sheets("VERİ").Cells(c.Row, "Q")
                Cells(sat, "R") = Dosya.Sheets("VERİ").Cells(c.Row, "R")
                Cells(sat, "S") = Dosya.Sheets("VERİ").Cells(c.Row, "S")
                Cells(sat, "T") = Dosya.Sheets("VERİ").Cells(c.Row, "T")
                Cells(sat, "U") = Dosya.Sheets("VERİ").Cells(c.Row, "U")
                Cells(sat, "V") = Dosya.Sheets("VERİ").Cells(c.Row, "V")
                Cells(sat, "W") = Dosya.Sheets("VERİ").Cells(c.Row, "W")
                Cells(sat, "X") = Dosya.Sheets("VERİ").Cells(c.Row, "X")
                Cells(sat, "Y") = Dosya.Sheets("VERİ").Cells(c.Row, "Y")
                Cells(sat, "Z") = Dosya.Sheets("VERİ").Cells(c.Row, "Z")
                Cells(sat, "AA") = Dosya.Sheets("VERİ").Cells(c.Row, "AA")
                Cells(sat, "AB") = Dosya.Sheets("VERİ").Cells(c.Row, "AB")
                Cells(sat, "AC") = Dosya.Sheets("VERİ").Cells(c.Row, "AC")
                Cells(sat, "AD") = Dosya.Sheets("VERİ").Cells(c.Row, "AD")
                Cells(sat, "AE") = Dosya.Sheets("VERİ").Cells(c.Row, "AE")
                Cells(sat, "AF") = Dosya.Sheets("VERİ").Cells(c.Row, "AF")
                Cells(sat, "AG") = Dosya.Sheets("VERİ").Cells(c.Row, "AG")
                Cells(sat, "AH") = Dosya.Sheets("VERİ").Cells(c.Row, "AH")
                Cells(sat, "AI") = Dosya.Sheets("VERİ").Cells(c.Row, "AI")
                Cells(sat, "AJ") = Dosya.Sheets("VERİ").Cells(c.Row, "AJ")
                Cells(sat, "AK") = Dosya.Sheets("VERİ").Cells(c.Row, "AK")
                Cells(sat, "AL") = Dosya.Sheets("VERİ").Cells(c.Row, "AL")
                Cells(sat, "AM") = Dosya.Sheets("VERİ").Cells(c.Row, "AM")
                Cells(sat, "AN") = Dosya.Sheets("VERİ").Cells(c.Row, "AN")
                Cells(sat, "AO") = Dosya.Sheets("VERİ").Cells(c.Row, "AO")
                Cells(sat, "AP") = Dosya.Sheets("VERİ").Cells(c.Row, "AP")
                Cells(sat, "AQ") = Dosya.Sheets("VERİ").Cells(c.Row, "AQ")
                Cells(sat, "AR") = Dosya.Sheets("VERİ").Cells(c.Row, "AR")
                Cells(sat, "AS") = Dosya.Sheets("VERİ").Cells(c.Row, "AS")
                Cells(sat, "AT") = Dosya.Sheets("VERİ").Cells(c.Row, "AT")
                Cells(sat, "AU") = Dosya.Sheets("VERİ").Cells(c.Row, "AU")
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
    
    Uygulama.Quit
End Sub

Ellerinize sağlık teşekkür ederim
Anacak ilk mesajımdaki 2. yapmak istediğim için nasıl bir yol izlemem gerekmekte

2. Bu kod sayfa aktif olduğunda çalışmakta ben excel dosyasını her açtığımda makro güvenlik uyarısına evet dedikten sonra hemen çalışarak verileri güncellemesini sağlamam gerekmekte.

Korhan Ayhan · 21 Haziran 2012

Merhaba,

Önceki önerdiğim kodu sayfanın kod bölümünden tamamen silin.

Aşağıdaki kodu boş bir modüle uygulayın.

İlk sayfanın veri aktarılacak sayfa olduğu varsayılmıştır.

Kod:

Sub AUTO_OPEN()
    Dim c As Range, sat As Long, ilkadres As Variant
    Dim Uygulama As Application, dosya As Workbook
    
    Sheets(1).Select
    Range("A5:AU" & Rows.Count).ClearContents
    sat = 5
    
    Set Uygulama = CreateObject("Excel.Application")
    Set dosya = Uygulama.Workbooks.Open(ThisWorkbook.Path & "\VERİ.xlsm")
    Uygulama.Visible = False
    
    With dosya.Sheets("VERİ").Range("R:R")
        Set c = .Find(ActiveSheet.Name, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            ilkadres = c.Address
            Do
                Range("A" & sat & ":AU" & sat).Value = dosya.Sheets("VERİ").Range("A" & c.Row & ":AU" & c.Row).Value
                sat = sat + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> ilkadres
        End If
    End With
    
    Uygulama.Quit
End Sub

Murat OSMA · 21 Haziran 2012

eneskus' Alıntı:
ADO ile uğraştım ama beceremedim yardım ederseniz cok memnun olurum.

ADO konusunda yardımcı olabilirim.
Kitap açıldığında kodların çalışmasını istiyorsanız; ya ThisWorkbook kod sayfasındaki Workbook_Open olayına yazacaksınız, ya da Module içerisine Sub Autpen() yazıp, kodları oraya yazacaksınız...

Korhan Bey'in önerdiği kodları dediğim yere yazarsanız, istediğiniz olacaktır...

Ayrıca ADO ile yapmak isterseniz, şu kodları ThisWorkbook kod sayfasına yazıp bir deneyiniz;

Kod:

Private Sub Workbook_Open()
    Dim con As Object, rs As Object
    Dim dosya As String
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    dosya = ThisWorkbook.Path & "\veri.xlsm"
        con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & dosya & _
        ";Extended Properties=""Excel 12.0;hdr=no"""
        sorgu = "Select * FROM [VERİ$] where [F18] = '" & ActiveSheet.Name & "'"
        rs.Open sorgu, con, 1, 1
        Range("A5").CopyFromRecordset rs
    rs.Close: con.Close
    Set con = Nothing: Set rs = Nothing: dosya = vbNullString
End Sub

Korhan Ayhan · 21 Haziran 2012

Merhaba,

Ben Murat beyin mesajını okuyunca hücrelerin ardışık gittiğini farkettim. Bu sebeple üstteki mesajlarımda önerdiğim kodları tekrar revize ettim. Hangisi işinize yarıyorsa kullanabilirsiniz.

Korhan Ayhan · 21 Haziran 2012

Merhaba,

Murat bey sizin kodu denediğimde aşağıdaki hatayı aldım.

Office 2010 da denedim.
Referanslardan "Microsoft ActiveX Data Objects 2.8 Library" işaretli durumda.

eneskus · 21 Haziran 2012

Murat OSMA, Korhan Ayhan Abilerim gerçekten çok teşekkür ederim elleriniz dert görmesin.

Murat OSMA · 21 Haziran 2012

Merhaba Korhan Bey,

Late Binding yönetimini kullandığım için ilgili referansı seçmenize gerek kalmıyor.
Şunu bir kontrol eder misiniz: kapalı olan dosyanın adı veri.xlsm (küçük harfle) olmalı. VERİ.xlsm olduğunda o hatayı verebilir.

Korhan Ayhan · 21 Haziran 2012

Merhaba,

Tamam o hatayı geçebildim. Dosya adı bende büyük harfle yazılmıştı. Şimdi bu sorun düzeldi.

Fakat şimdi de aşağıdaki hatayı veriyor.

DEBUG dediğimde;

rs.Open Sorgu, con, 1, 1 satırında hata veriyor.

Oluşan sorgu;
Select * FROM [VERİ$] where [F18] = '07 CFB 06'

eneskus · 24 Temmuz 2012

AMBAR ÇIKIŞ BONOSU KAYIT.xlsm dosyasında AMBAR ÇIKIŞ BONOSU VERİ GİRİŞİ sayfasında n10:n hüçrelerindeki verileri VERİ.xlsm dosyası VERİ sayfası bj3:bj arsına aktaran makro lazım. Teşekkür ederim.

pashazeus · 24 Temmuz 2012

merhaba

arkadaşlar en uygun kategori bu konuyu bulduğum için buraya yazıyorum. yukarıda belirtildiği şekilde benim de bir veri excellim var, ama bu ecxell içerisinde 30-40 bin kayıt bulunuyor. ben her ay bu sayfadan filtreyelerek veya Pivot kullanarak istediğim kişilerin yapmış olduğu işlemleri tek tek rapor alıyorum, e malumunuz bu da benim baya bir zamanımı alıyor.

yapmak istediğim bu excell dosyası içerisinde bulunan 30 kullanıcı için ayrı ayrı exceller oluşturmak, oluşturduğum her excell örnek ahmet.xlsm dosyası nı açtığım zaman bana ana excellden ahmet ismini bulacak ve bu oluşturduğum excelle ahmet isminin bulunduğu sütun'u ilgili excell içerisine update edecek, yalnız burada sofor hata olması çok önemli. ana dosyada Ahmet 3, Ahmet Suat, gibi isimler var ise bunu bana getirmemelidir. sadece Ahmet olan stunları hatasız getirmelidir.

uzman bilgilerinize dayanarak yardımlarınızı rica ederim.

teşekkürler
iyi çalışmalar

eneskus · 24 Temmuz 2012

AMBAR ÇIKIŞ BONOSU KAYIT.xlsm dosyasında AMBAR ÇIKIŞ BONOSU VERİ GİRİŞİ sayfasında n10:n hüçrelerindeki verileri VERİ.xlsm dosyası VERİ sayfası bj3:bj arsına aktaran makro lazım.

Aşağıdaki Makro ile vei aldım ancak bu makroda bir düzenleme ile sadece dolu hüçreleri almasını sağlayabilirmiyiz.

Kod:

Sub aa()
Dim Satır As Long, Sütun As Byte, Son_Satır As Long, Son_Sütun As Byte
  
    For Satır = 3 To 303
        For Sütun = 62 To 62
        Cells(Satır, Sütun).ClearContents
            Cells(Satır, Sütun) = ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[AMBAR ÇIKIŞ BONOSU KAYIT.xlsm]AMBAR ÇIKIŞ BONOSU VERİ GİRİŞİ'!R" & Satır + 7 & "C" & 14 & "")
        Next
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Murat OSMA · 24 Temmuz 2012

Alternatif olarak ADO ile verileri daha hızlı ve sorunsuz alabilirsiniz;

Kod:

Sub Emre()
    Dim con As Object, rs As Object
    Dim dosya As String, sorgu As String
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    dosya = ThisWorkbook.Path & "\AMBAR ÇIKIŞ BONOSU KAYIT.xlsm"
        con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dosya & _
        ";Extended Properties=""Excel 12.0;hdr=NO"""
        sorgu = "Select * FROM [AMBAR ÇIKIŞ BONOSU VERİ GİRİŞİ$N10:N173]"
        rs.Open sorgu, con, 1, 1
        Range("BJ3").CopyFromRecordset rs
    rs.Close: con.Close
    Set con = Nothing: Set rs = Nothing
    dosya = vbNullString: sorgu = vbNullString
End Sub

eneskus · 24 Temmuz 2012

Murat bey vermiş olduğunuz kodlar gercekten cok hızlı ilginiz için çok teşekkürler.

İzninizle 1 soru da soracam önceki vermiş olduğunuz kodlarda n10:n173 arası verileri sırasıyla aktarmaktaydı. Şimdi c2:c374 arası verileri 12 hüçre atlayarak almam gerekmekte yani c2 hüçresini alacak sonra c14 sonra c26 bu şekilde c374 e kadar devam edecek kodda nasıl bir düzenleme yapmamız gerekmekte acaba.

Murat OSMA · 24 Temmuz 2012

Tablolarınızı daha düzenli yaparsanız; istediğiniz veriyi almanız da o kadar kolaylaşır...

Malzeme Adı yazan satırı, yani o tabloyu ilk satıra aldığınız zaman aralık belirtmenize gerek kalmadan komple o sütunu alabilirsiniz. C sütun için de kodlarda yeni bir alan belirterek verileri isterseniz sıralı isterseniz olduğu gibi alabilirsiniz... Gördüğüm kadarıyla sizin C sütununa girdiğiniz veri ile yeni bir sayfa oluşuyor. Yani oluşan bu sayfa isimlerini istediğiniz sütunda sıralayabilirsiniz. Bunun için ADO'ya da gerek yok. Sitede bir çok örnek var zaten.

Murat OSMA · 24 Temmuz 2012

Ne yaptınız Sn. eneskus ?

baska dosyadan veri alan macro

eneskus

Ekli dosyalar

serqet

eneskus

eneskus

Korhan Ayhan

Administrator

eneskus

Korhan Ayhan

Administrator

Murat OSMA

Altın Üye

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

eneskus

Murat OSMA

Altın Üye

Korhan Ayhan

Administrator

eneskus

Ekli dosyalar

pashazeus

eneskus

Murat OSMA

Altın Üye

eneskus

Murat OSMA

Altın Üye

Murat OSMA

Altın Üye