• DİKKAT

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

2 dosya arasında koşullu veri aktarımı

  • Konbuyu başlatan Konbuyu başlatan Metin_S
  • Başlangıç tarihi Başlangıç tarihi
M

Metin_S

Katılım
20 Kasım 2009
Mesajlar
89
Excel Vers. ve Dili
MS Office 2016 TR
Merhaba, 2 ayrı excel dosyam var, Liste ve Tablo. Tablo dosyası içine koşullu olarak Liste dosyasından bilgi almak istiyorum. Örneğin; Liste içinde A1 sütununda Kod sütunu var. Tablo sütununda KOD: yazan yerin karşısındaki hücreye 1 yazdığımda Liste içindeki Kod 1 olanlar gelecek, 2 yazdığımda 2 olanlar vb. örnek dosyalarım ektedir. yardımlarınız için şimdiden teşekkür ederim.
 

Ekli dosyalar

Merhaba

Biraz acemice sanırım fakat çalışıyor
Umarım işinize yarar

Sub aktar()
a = Range("i2").Value
Workbooks.Open Filename:="c:\liste.xls"
Worksheets("sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:=a
Range("A1:E10").Select
Selection.Copy
Windows("tablo.xls").Activate
Worksheets("sheet1").Select
Range("a1").Select
ActiveSheet.Paste
Range("i2").Select
Windows("liste.xls").Activate
ActiveWorkbook.Close False


End Sub
 
Dosyanız ektedir.:cool:
Kod: 
Sub kapali_dosya_aktar()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim sat As Long, i As Byte
'Tools referenceden Microsoft activex data object 2.8 library seçildi
Sheets("Sheet1").Select
Application.ScreenUpdating = False
If Range("I2").Value = "" Then
    MsgBox "I2 hücresi boş.Kod akatarımı için I2 hücresine sayısal bir kod giriniz.", vbCritical, "UYARI"
    Exit Sub
End If
sat = 2
Range("A2:E65536").ClearContents
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
conn.Open "Provider=microsoft.jet.oledb.4.0;data source= " & ThisWorkbook.Path & "\Liste.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [Sheet1$] where kod =" & Range("I2").Value & " order by Adı;", conn, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 65534 Then
    MsgBox "çok sayıda veri var sayfaya sığmayacağından dolayı veri aktarılmadı", vbCritical, "UYARI"
    GoTo atla
End If

If rs.RecordCount > 0 Then
    rs.MoveFirst
    Do While Not rs.EOF
        Cells(sat, "A").Value = rs("Sıra").Value
        Cells(sat, "B").Value = rs("SeriNo").Value
        Cells(sat, "C").Value = rs("Adı").Value
        Cells(sat, "D").Value = rs("Türü").Value
        sat = sat + 1
        rs.MoveNext
    Loop
    Application.ScreenUpdating = True
    MsgBox "Aktarım yapıldı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    Else
    Application.ScreenUpdating = True
    MsgBox "[ " & Range("I2").Value & " ] Bulunamdı.", vbCritical, "UYARI"
End If
atla:
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub
 

Ekli dosyalar

  • 59.rar
    59.rar
    16.9 KB · Görüntüleme: 80
ian_em sağol kodun işe yaradı ama liste örnekte gönderdiğim kadar kısa değil o yüzden alacak bilgiyi eksik alıyor
 
evren gizlen merhaba, kod hata veriyor conn As ADODB.Connection bölümünde acaba benmi yanlış yaptım
 
Metin_S' Alıntı:
evren gizlen merhaba, kod hata veriyor conn As ADODB.Connection bölümünde acaba benmi yanlış yaptım
Genişletmek için tıkla ...
Kodu başka bir dosyaya aldınız sanırım
Kodun en başına yazmıştım.VBE'de
Tools==>referenceden microsoft activex dataobject 2.8 library aktif etmeniz gerekir.:cool:
 
Evren Gizlen sağol aktif etme işleminden sonra düzeldi çok teşekkür ederim. İlgine teşekkür ederim. Eline sağlık.
 
Evren Gizlen birşey daha rica edicem. Gönderdiğim Tablo.xls dosyasında A1 de kod sütunu olmayacaktı haliyle Liste.xls den kod sütununu almaması lazım bunu nasıl çözebiliriz. Şimdiden sağol
 
Metin_S' Alıntı:
Evren Gizlen birşey daha rica edicem. Gönderdiğim Tablo.xls dosyasında A1 de kod sütunu olmayacaktı haliyle Liste.xls den kod sütununu almaması lazım bunu nasıl çözebiliriz. Şimdiden sağol
Genişletmek için tıkla ...
Kodda aşağıdaki kırmızı yeri ekleyin.:cool:
Kod: 
If rs.RecordCount > 0 Then
Range("A2").CopyFromRecordset rs
 [B][COLOR="Red"]   Range("A2:A65536").ClearContents[/COLOR][/B]
 
Tablo dosyasına kod sütunu gelmedi fakat alınan bilgi B2 sütunundan değilde A2 sütunundan itibaren başlayacak. Yani Listedeki B2 sütunu Tablo dosyasında A2 sütununa gelecek diğerleride bu sırayla olacak.
 
Metin_S' Alıntı:
Tablo dosyasına kod sütunu gelmedi fakat alınan bilgi B2 sütunundan değilde A2 sütunundan itibaren başlayacak. Yani Listedeki B2 sütunu Tablo dosyasında A2 sütununa gelecek diğerleride bu sırayla olacak.
Genişletmek için tıkla ...
Önceki kodlarla aşağıdaki kırmızı satırları deiğiştiriniz.:cool:
Kod: 
If rs.RecordCount > 0 Then
    Range("A2").CopyFromRecordset rs
    [B][COLOR="Red"]Range("B2:E" & Cells(65536, "A").End(xlUp).Row).Cut
    Range("A2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False[/COLOR][/B]
    Application.ScreenUpdating = True
    Range("A1").Select

    MsgBox "Aktarım yapıldı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
 
İstediğim gibi oldu sağol fakat Tablo dosyasında E sütununda formüllerim vardı onları sildi neden olabilir
 
Metin_S' Alıntı:
İstediğim gibi oldu sağol fakat Tablo dosyasında E sütununda formüllerim vardı onları sildi neden olabilir
Genişletmek için tıkla ...
Çünkü hepsini oraya atıyor.Sonra ben kesip tekrar a sütununa atıyorum.Aslında bu 2nci bir işlem oluyor.Olmasa ilk anda olduğu gibi kullansanız kod dahada hızlı çalışacak.Tasarımınızı o duruma göre yapsanız daha iyi olur.
Ama illa E sütunundaki formüllerim kalsın onlara dokunulmasın istiyorsanız ben record set içinde döngüye girer o şekilde yaparım.Ama çok veri olduğunda bu daha da yavaşlamaya sebep olur.
İsterseniz e sütunan hiç dokunmadan döbgüye girerek verileri atayım.:cool:
 
İlgine çok teşekkür ederim. E ve sonrasındaki 10 sütunda başka bilgiler var. Liste dosyasından aldığım B-C-D-E sütunlarındaki bilgi Tablo dosyasında A-B-C-D sütunlarına gelmesi gerekiyor. Bir seferde alınan bilgi en fazla 60-70 satır oluyor o yüzden çok fazla yavaşlık olmaz diye düşünüyorum. Eğer, record set içinde bu döngüyü yaparsanız çok sevinirim. Senide çok uğraştırdım eline sağlık.
 
Metin_S' Alıntı:
İlgine çok teşekkür ederim. E ve sonrasındaki 10 sütunda başka bilgiler var. Liste dosyasından aldığım B-C-D-E sütunlarındaki bilgi Tablo dosyasında A-B-C-D sütunlarına gelmesi gerekiyor. Bir seferde alınan bilgi en fazla 60-70 satır oluyor o yüzden çok fazla yavaşlık olmaz diye düşünüyorum. Eğer, record set içinde bu döngüyü yaparsanız çok sevinirim. Senide çok uğraştırdım eline sağlık.
Genişletmek için tıkla ...
Dosyayı isteğiniz doğrultusunda 3 numaralı mesajda güncelledim.Oradan indirebilirsiniz.:cool:
 
Evren Gizlen tamamdır bu iş sana ne kadar teşekkür etsem azdır. Beni çok büyük bir iş yükünden kurtardın eline sağlık sağolasın.
 
Son bir düzenleme

Evren Gizlen merhaba, biliyorum çok oluyorum ama :) son birşey rica edicem. Tablo dosyasının açıklamalı son halini ekliyorum bakabilirsen sevinirim. Şimdiden teşekkür ederim.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst