kapalı 2 dosyadan butonla veri çekme

[asilme]

arkadaşlar öncelikle belirteyim kapalı 2 dosyadan butonla 2 şer sayfasının verilerini çekme diye birşey formda bulamadım. istediğim bir klasör içerisinde 3 adet excel dosyası var (ilçe,fatih ve murat)ilçe dosyasndaki ilçe tut sayfasına koyacağım buton ile fatihve murat kitabındaki fatih tut ve murat tut sayfalarını ilçe kitabındaki kendi adlarındaki (fatih tut ve murat tut sayfalarınagetirecek)aynı şekilde fatih mev ve murat mev de aynı şekilde olacak ancak birini yaparsanız ben sayfa adlarını değiştirerek mev sayfalarını yaparım herhalde yardımlarınınz için teşekkürler

 

[asilme]

arkadaşlar işlem mümkün değilmi konu hakkında bilgisi olan varsa lütfen yardım edermi

 

[Murat OSMA]

İçi boş dosyalar yerine birkaç satır da olsa veri ekleyip gönderseydiniz belki ilgilenen çıkardı.

 

[asilme]

dosya içerisine veri ekledim bilgisi olan varsa yardımcı olsun

 

[Murat OSMA]

Belki bu şekilde detaya gerek yoktu diyeceksiniz ama yine de biraz renk katmak istedim.

■ Modül kodları;

Sub Emre()
    UserForm1.Show
End Sub

Sub Auto_Open()
    Dim evn As Object, dosya As Object
    Sayfa2.Columns("z").ClearContents
    Set evn = CreateObject("Scripting.FileSystemObject")
    For Each dosya In evn.GetFolder(ThisWorkbook.Path).Files
        If Left(Replace(dosya.Name, "~$", ""), 4) <> "ilçe" Then
            Sayfa2.Range("Z65536").End(3)(2, 1) = dosya.Name
        End If
    Next dosya
    Set dosya = Nothing: Set evn = Nothing
End Sub

■ UserForm kodları;

Private Sub CommandButton1_Click()
    Dim con As Object, rs As Object
    Dim sorgu As String, dosya As String
    If ListBox1.ListIndex = -1 Then MsgBox "Dosya Seçimi Yapmadınız", _
    vbCritical + vbMsgBoxRtlReading, "U Y A R I": Exit Sub
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordSet")
    ListBox2.Clear
    dosya = ListBox1.Value
    con.Open "Provider=Microsoft.ace.oledb.12.0;Data Source=" & _
    ThisWorkbook.Path & "\" & dosya & ";Extended Properties=""Excel 12.0;hdr=no"""
    ListBox2.Clear
    isim = Array(" tut", " mev")
    For a = 0 To 1
        sorgu = "Select * FROM [" & Replace(ListBox1.Value, ".xlsm", "") & isim(a) & "$A2:H10000] where not isnull(f1)"
        rs.Open sorgu, con, 1, 1
        With ListBox2
        Do Until rs.EOF
            .ColumnCount = 8
            .ColumnWidths = 50
            .AddItem rs(0).Value
            .List(.ListCount - 1, 1) = rs(1).Value
            .List(.ListCount - 1, 2) = rs(2).Value
            .List(.ListCount - 1, 3) = rs(3).Value
            .List(.ListCount - 1, 4) = rs(4).Value
            .List(.ListCount - 1, 5) = rs(5).Value
            .List(.ListCount - 1, 6) = rs(6).Value
            .List(.ListCount - 1, 7) = rs(7).Value
            rs.MoveNext
        Loop
        If MsgBox("? Veriler Aktarılsın mı", vbInformation + _
            vbMsgBoxRtlReading + vbYesNo, "Aktarmadan Önceki Son Çıkış") = vbNo Then
            MsgBox "Aktarım İptal Edildi", vbExclamation + vbMsgBoxRtlReading, "Son Durum": .Clear: Exit Sub
                Else
            sayfa = Replace(ListBox1.Value, ".xlsm", "") & isim(a)
            Sheets(sayfa).Select
            Dim Satir As Integer, Sutun As Integer
            Satir = UBound(.List, 1)
            Sutun = UBound(.List, 2)
            Range(Cells(2, 1), Cells(2 + Satir, 1 + Sutun)).Value = .List
        End If
        End With
        ListBox2.Clear
    rs.Close
    Next a
    con.Close
    Set con = Nothing: Set rs = Nothing: dosya = vbNullString
End Sub

Private Sub UserForm_Initialize()
    For i = 2 To Sayfa2.Range("Z65536").End(3).Row
        ListBox1.AddItem Sayfa2.Cells(i, "Z")
    Next i
    ListBox2.Height = ListBox1.Height
End Sub

Dosyanız ek'te...

 

[asilme]

murat osma hocam elinize sağlık çok güzel olmuş

 

[Murat OSMA]

Rica ederim, iyi günler.