• DİKKAT

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

Soru Kapalı Dosyadan Veri Almak

  • Konbuyu başlatan Konbuyu başlatan ormann
  • Başlangıç tarihi Başlangıç tarihi
O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
İyi günler ekli Ebat Listesi dosyasında veri girişi sayfasındaki Veri Al butonu ile ekli İstif dosyasındaki istif sayfasının aşağıda velirtmiş olduğum hücrelerindeki verileri makro ile veri girişi sayfasında ilgili yerlere makro aldırabilirmiyiz.
Link : https://dosya.co/womtsv6vns0y/Dosyalar.rar.html

Veri Alınacak İstif Dosyasının İstif Sayfasındaki ;
C1 >J7 hücresine
C2>J4 Hücresine
C3>J5 Hücresine
C4>J6 Hücresine
C5>J8 Hücresine
L4>J10 Hücresine
A10:A59>F20:F69 Hücresine
B8>G18 Hücresine
E8>H18 hücresine
H8>I18 hücresine
K8>J18 Hücresine
N8>K18 Hücresine
Q8>L18 Hücresine
T8>M18 Hücresine
W8>M18 Hücresine
B10:B59>G20:G69 Hücresine
E10:E59>H20:H69 Hücresine
H10:H59>I20:I69 Hücresine
K10:K59>J20:J69 Hücresine
N10:N59>K20:K69 Hücresine
Q10:Q59>L20:L69 Hücresine
T10:T59>M20:M69 Hücresine
W10:W59>N20:N69 Hücresine
 
Aşağıdaki bölümde mükerrerlik söz konusu olmuş. Doğrusu nedir?

T8>M18 Hücresine
W8>M18 Hücresine
 
Korhan bey, yanlış yazmışım
T8>M18
W8>N18 hücresine olacaktı
 
Deneyiniz.

C++: 
Option Explicit

Sub Verileri_Aktar()
    Dim Dosya As String, Baglanti As Object, Sorgu As String
    Dim Kayit_Seti As Object, S1 As Worksheet, Zaman As Double
    Dim Veri_Adresi As Variant, Hedef_Adres As Variant, X As Byte
    
    Zaman = Timer
    
    Set S1 = Sheets("VERİ GİRİŞİ")
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    
    Dosya = ThisWorkbook.Path & Application.PathSeparator & "İSTİF.xlsm"
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Veri_Adresi = Array("C1:C1", "C2:C2", "C3:C3", "C4:C4", "C5:C5", "L4:L4", "A10:A59", "B8:B8", _
                  "E8:E8", "H8:H8", "K8:K8", "N8:N8", "Q8:Q8", "T8:T8", "W8:W8", "B10:B59", _
                  "E10:E59", "H10:H59", "K10:K59", "N10:N59", "Q10:Q59", "T10:T59", "W10:W59")
    
    Hedef_Adres = Array("J7", "J4", "J5", "J6", "J8", "J10", "F20", "G18", _
                  "H18", "I18", "J18", "K18", "L18", "M18", "N18", "G20", _
                  "H20", "I20", "J20", "K20", "L20", "M20", "N20")
    
    For X = 0 To UBound(Veri_Adresi)
        Sorgu = "Select * From [İSTİF$" & Veri_Adresi(X) & "]"
        Set Kayit_Seti = Baglanti.Execute(Sorgu)
        S1.Range(Hedef_Adres(X)).CopyFromRecordset Kayit_Seti
    Next
    
    Kayit_Seti.Close
    Baglanti.Close
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Korhan bey dosya yı kendimiz seçebilsek .Dosya Aç şeklinde. Dosya adı bazen farklı oluyor.Fakat sayfa ismi sabit değişmiyor. Dosya ismi İstif=8, İstif=9 vb.. şekilde olabiliyor. Dosyaları bütün excel formatların dan alabilir mi?
 
Lütfen taleplerinizi ilk mesajınızda vermeye özen gösteriniz.
 
Çok özür diliyorum.Kullandıkca aklıma geliyor
 
Deneyiniz.

C++: 
Option Explicit

Sub Verileri_Aktar()
    Dim Dosya As Variant, Baglanti As Object, Sorgu As String
    Dim Kayit_Seti As Object, S1 As Worksheet, Zaman As Double
    Dim Veri_Adresi As Variant, Hedef_Adres As Variant, X As Byte
    
    Zaman = Timer
    
    Set S1 = Sheets("VERİ GİRİŞİ")
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    
    Dosya = Application.GetOpenFilename("Excel Dosyaları (*.xl*),*.xl*", , "Hedef Dosyayı Seçin")
    If Dosya = False Then Exit Sub
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Veri_Adresi = Array("C1:C1", "C2:C2", "C3:C3", "C4:C4", "C5:C5", "L4:L4", "A10:A59", "B8:B8", _
                  "E8:E8", "H8:H8", "K8:K8", "N8:N8", "Q8:Q8", "T8:T8", "W8:W8", "B10:B59", _
                  "E10:E59", "H10:H59", "K10:K59", "N10:N59", "Q10:Q59", "T10:T59", "W10:W59")
    
    Hedef_Adres = Array("J7", "J4", "J5", "J6", "J8", "J10", "F20", "G18", _
                  "H18", "I18", "J18", "K18", "L18", "M18", "N18", "G20", _
                  "H20", "I20", "J20", "K20", "L20", "M20", "N20")
    
    For X = 0 To UBound(Veri_Adresi)
        Sorgu = "Select * From [İSTİF$" & Veri_Adresi(X) & "]"
        Set Kayit_Seti = Baglanti.Execute(Sorgu)
        S1.Range(Hedef_Adres(X)).CopyFromRecordset Kayit_Seti
    Next
    
    Kayit_Seti.Close
    Baglanti.Close
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Korhan hocam çok teşekkür ederim.İyi akşamlar
 
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Option Explicit

Sub Verileri_Aktar()
    Dim Dosya As String, Baglanti As Object, Sorgu As String
    Dim Kayit_Seti As Object, S1 As Worksheet, Zaman As Double
    Dim Veri_Adresi As Variant, Hedef_Adres As Variant, X As Byte
   
    Zaman = Timer
   
    Set S1 = Sheets("VERİ GİRİŞİ")
   
    Set Baglanti = CreateObject("AdoDb.Connection")
   
    Dosya = ThisWorkbook.Path & Application.PathSeparator & "İSTİF.xlsm"
   
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
   
    Veri_Adresi = Array("C1:C1", "C2:C2", "C3:C3", "C4:C4", "C5:C5", "L4:L4", "A10:A59", "B8:B8", _
                  "E8:E8", "H8:H8", "K8:K8", "N8:N8", "Q8:Q8", "T8:T8", "W8:W8", "B10:B59", _
                  "E10:E59", "H10:H59", "K10:K59", "N10:N59", "Q10:Q59", "T10:T59", "W10:W59")
   
    Hedef_Adres = Array("J7", "J4", "J5", "J6", "J8", "J10", "F20", "G18", _
                  "H18", "I18", "J18", "K18", "L18", "M18", "N18", "G20", _
                  "H20", "I20", "J20", "K20", "L20", "M20", "N20")
   
    For X = 0 To UBound(Veri_Adresi)
        Sorgu = "Select * From [İSTİF$" & Veri_Adresi(X) & "]"
        Set Kayit_Seti = Baglanti.Execute(Sorgu)
        S1.Range(Hedef_Adres(X)).CopyFromRecordset Kayit_Seti
    Next
   
    Kayit_Seti.Close
    Baglanti.Close
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Genişletmek için tıkla ...
Korhan bey ben bu kodlarınızı kendi çalışmama uyarladım gayet güzel çalıştı. Yapmak istediğim çalışma sayfamın F23 sütununda Etkin yazan personelleri getirtmek istiyorum. Sorgu satırında nasıl bir değişiklik yapabilirim.
Kod: 
 Veri_Adresi = Array("A:A", "B:B", "C:C", "D:D", "G:G")
    
    Hedef_Adres = Array("A6", "B6", "C6", "D6", "E6")
    
    For X = 0 To UBound(Veri_Adresi)
        Sorgu = "Select * From [GRUPLAR$" & Veri_Adresi(X) & "]"    'VERİ ALDIĞIMIZ SAYFANIN İSMİ
        Set Kayit_Seti = Baglanti.Execute(Sorgu)
        S1.Range(Hedef_Adres(X)).CopyFromRecordset Kayit_Seti
 
F23 sütunu olmaz. F23 hücresi olabilir. Ya da F sütunu olabilir.

Sorgu şu şekilde olabilir.

C++: 
"Select * From [GRUPLAR$" & Veri_Adresi(X) & "] Where [Sütun Başlığınız] = 'Etkin'"
 
Korhan hocam birde ekli dosyada aktar butonu ile veriler masaüstüne Ebat Listesi klasörü içerisine veri girişi sayfasında J5 hücresindeki isimle dosya olarak kayıt yapılıyor. Kayıt yapılan dosyanın istifEbatExcelsayfası içerisine ÇAP;BOY;ADET olarak aktarılıyor.Bu aktarılan kaydı tekrar aynı yerlerine (Çapı,Adedi,İstif Numarası ,Cinsi) geri alabilir miyiz ?

İndir EBAT LİSTESİ PROGRAMI

Dosyayı indir EBAT LİSTESİ PROGRAMI
dosya.co
 
Korhan Ayhan' Alıntı:
F23 sütunu olmaz. F23 hücresi olabilir. Ya da F sütunu olabilir.

Sorgu şu şekilde olabilir.

C++: 
"Select * From [GRUPLAR$" & Veri_Adresi(X) & "] Where [Sütun Başlığınız] = 'Etkin'"
Genişletmek için tıkla ...
Korhan Hocam Denedim ama olmadı Örnek dosya paylaşıyorum. Örnek dosya mevcut konumu ile çalışıyor Aynı zamanda Etkin koşulu olmadan getirttiğim zaman A ve B sütunlarının başlıklarını getirmiyor
 

Ekli dosyalar

Bunu deneyin ...

Kod: 
Sub Verileri_Aktar()
    Dim Dosya As String, Baglanti As Object, Sorgu As String
    Dim Kayit_Seti As Object, S1 As Worksheet, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Takip_listesi")
    
    Set Baglanti = CreateObject("ADODB.Connection")
    
    Dosya = ThisWorkbook.Path & Application.PathSeparator & "deneme.xlsx"
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
                  Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Sorgu = "Select F1, F2, F3, F4 From [GRUPLAR$] where F23='Etkin'"
    Set Kayit_Seti = Baglanti.Execute(Sorgu)
    S1.Range("A6").CopyFromRecordset Kayit_Seti
    
    Kayit_Seti.Close
    Baglanti.Close
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub


.
 
Haluk' Alıntı:
Bunu deneyin ...

Kod: 
Sub Verileri_Aktar()
    Dim Dosya As String, Baglanti As Object, Sorgu As String
    Dim Kayit_Seti As Object, S1 As Worksheet, Zaman As Double
    Dim Veri_Adresi As Variant, Hedef_Adres As Variant, X As Byte
   
    Zaman = Timer
   
    Set S1 = Sheets("Takip_listesi")
   
    Set Baglanti = CreateObject("ADODB.Connection")
   
    Dosya = ThisWorkbook.Path & Application.PathSeparator & "deneme.xlsx"
   
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
                  Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
   
    Sorgu = "Select F1, F2, F3,F4 From [GRUPLAR$] where F23='Etkin'"
    Set Kayit_Seti = Baglanti.Execute(Sorgu)
    Range("A6").CopyFromRecordset Kayit_Seti
   
    Kayit_Seti.Close
    Baglanti.Close
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub


.
Genişletmek için tıkla ...
Haluk hocam verileri başlıkları ile birlikte getirmek mümkünmü acaba
 
@Haluk beyin cevabından sonra mesajımı düzeltme ihtiyacı hissettim.

Ben F23 ifadesini hücre adresi olarak yorumladığım için sütun olamaz ifadesini kullandım. Yanlış anlaşılmayı bu mesajımla düzeltelim. F23 ifadesi sorguda W sütununu ifade ediyor.
 
Korhan Ayhan' Alıntı:
@Haluk beyin cevabından sonra mesajımı düzeltme ihtiyacı hissettim.

Ben F23 ifadesini hücre adresi olarak yorumladığım için sütun olamaz ifadesini kullandım. Yanlış anlaşılmayı bu mesajımla düzeltelim. F23 ifadesi sorguda W sütununu ifade ediyor.
Genişletmek için tıkla ...
Korhan hocam sizin makronuza uygularken sütun başlığı olarakta uyguladım F23 olarakta W olarakta uyguladım ama bir türlü sonuç alamadım
 
metin_0606' Alıntı:
Haluk hocam verileri başlıkları ile birlikte getirmek mümkünmü acaba
Genişletmek için tıkla ...


Kod: 
Sub Verileri_Aktar()
    Dim Dosya As String, Baglanti As Object, Sorgu As String
    Dim Kayit_Seti As Object, S1 As Worksheet, Zaman As Double
    Dim j As Integer
    
    Zaman = Timer
    
    Set S1 = Sheets("Takip_listesi")
    
    Set Baglanti = CreateObject("ADODB.Connection")
    
    Dosya = ThisWorkbook.Path & Application.PathSeparator & "deneme.xlsx"
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
                  Dosya & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
    
    Sorgu = "Select [Başlık1], [Başlık2], [Başlık3], [Başlık4] From [GRUPLAR$] where [Başlık23]='Etkin'"
    
    Set Kayit_Seti = CreateObject("ADODB.Recordset")
    
    Kayit_Seti.Open Sorgu, Baglanti
    
    For j = 0 To Kayit_Seti.Fields.Count - 1
        S1.Cells(5, j + 1) = Kayit_Seti.Fields(j).Name
    Next
    
    S1.Range("A6").CopyFromRecordset Kayit_Seti
    
    Kayit_Seti.Close
    Baglanti.Close
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

.
 
Haluk' Alıntı:
Kod: 
Sub Verileri_Aktar()
    Dim Dosya As String, Baglanti As Object, Sorgu As String
    Dim Kayit_Seti As Object, S1 As Worksheet, Zaman As Double
    Dim j As Integer
   
    Zaman = Timer
   
    Set S1 = Sheets("Takip_listesi")
   
    Set Baglanti = CreateObject("ADODB.Connection")
   
    Dosya = ThisWorkbook.Path & Application.PathSeparator & "deneme.xlsx"
   
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
                  Dosya & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
   
    Sorgu = "Select [Başlık1], [Başlık2], [Başlık3], [Başlık4] From [GRUPLAR$] where [Başlık23]='Etkin'"
   
    Set Kayit_Seti = CreateObject("ADODB.Recordset")
   
    Kayit_Seti.Open Sorgu, Baglanti
   
    For j = 0 To Kayit_Seti.Fields.Count - 1
        S1.Cells(5, j + 1) = Kayit_Seti.Fields(j).Name
    Next
   
    S1.Range("A6").CopyFromRecordset Kayit_Seti
   
    Kayit_Seti.Close
    Baglanti.Close
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

.
Genişletmek için tıkla ...
Teşekkürler hocam saygılar
 
Günaydın ,
Ebat listesi sayfasında A1 hücresine sayfa ismini verdiğimizde aşağıdaki kodu İstif sayfasında degilde A1 hücresine verilen isimle veri alması için aşağıdaki kodu nasıl değiştirebiliriz
Kod: 
Sorgu = "Select * From [İSTİF$" & Veri_Adresi(X) & "]"
        Set Kayit_Seti = Baglanti.Execute(Sorgu)
        S1.Range(Hedef_Adres(X)).CopyFromRecordset Kayit_Seti
    Next
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst