• DİKKAT

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

Dosya Yolunu belirttiğim sayfadan sıralı veri çekme

I

iaslan517

Katılım
24 Şubat 2017
Mesajlar
88
Excel Vers. ve Dili
2010-Türkçe
Merhabalar, öncelikler herkese iyi çalışmalar diliyorum. Ekte belirttiğim dosyalarda kapalı ve klasörler içinde olan bir excelden buton yardımı ile sayfa1 ' deki tablodan verileri olduğu gibi çekebilecek, veri yollarını değiştirdikçe aynı anda hemen altına bir boşluk bırakarak tabloları sıralayabilecek bir dosyaya ihtiyacım var. yardımlarınızı rica ediyorum.
 

Ekli dosyalar

Aşağıdaki kodları bir module yapıştırıp deneyin.
Kod: 
Sub askm_Kapalidan_Veri_Cek()
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
SonSat = s2.Cells(Rows.Count, 1).End(xlUp).Row
sonsat1 = s1.Cells(Rows.Count, 2).End(xlUp).Row + 2

Dim k1 As String

Dim Fs As Object
    
    Set Fs = CreateObject("Scripting.FileSystemObject")

For i = 1 To SonSat

k1 = s2.Range("A" & i).Value
yol = ThisWorkbook.Path & "\Cekilecek Klasor\" & s2.Range("A" & i).Value & ".xlsx"
If Fs.FileExists(yol) Then
    Application.ScreenUpdating = False
    Workbooks.Open (yol)
    Workbooks("ANA EXCEL").Sheets("Sayfa1").Range("A" & sonsat1) = yol
    sonsat1 = sonsat1 + 1
    Workbooks(s2.Range("A" & i).Value).Sheets("Sayfa1").Range("A1:C1000").Copy _
    Workbooks("ANA EXCEL").Sheets("Sayfa1").Range("B" & sonsat1)
    Workbooks(k1).Close True
    Application.ScreenUpdating = False
Else
    s2.Range("B" & i).Value = "Dosya Yok"
End If
Next
MsgBox "İşlemi tamamlandı...", vbInformation, "ASKM"
End Sub
 
Dosyanız ektedir.:cool:
Kod: 
Sub aktar59()
Dim conn As Object, rs As Object, sonsat As Long
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("Adodb.recordset")
dosya = Dir(ThisWorkbook.Path & "\Cekilecek Klasor\*.xlsx")
Application.ScreenUpdating = False
Do While dosya <> ""
    conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\Cekilecek Klasor\" _
            & dosya & ";extended properties=""excel 12.0;hdr=no""")
    rs.Open "select * from [Sayfa1$];", conn, 1, 1
    If rs.RecordCount > 0 Then
        sonsat = Cells(Rows.Count, "B").End(xlUp).Row + 2
        Range("B" & sonsat).CopyFromRecordset rs
        Range("A" & sonsat).Value = ThisWorkbook.Path & "\Cekilecek Klasor\" & dosya
    End If
    rs.Close: conn.Close
    dosya = Dir
Loop
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub
 

Ekli dosyalar

Orion1' Alıntı:
Dosyanız ektedir.:cool:
Kod: 
Sub aktar59()
Dim conn As Object, rs As Object, sonsat As Long
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("Adodb.recordset")
dosya = Dir(ThisWorkbook.Path & "\Cekilecek Klasor\*.xlsx")
Application.ScreenUpdating = False
Do While dosya <> ""
    conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\Cekilecek Klasor\" _
            & dosya & ";extended properties=""excel 12.0;hdr=no""")
    rs.Open "select * from [Sayfa1$];", conn, 1, 1
    If rs.RecordCount > 0 Then
        sonsat = Cells(Rows.Count, "B").End(xlUp).Row + 2
        Range("B" & sonsat).CopyFromRecordset rs
        Range("A" & sonsat).Value = ThisWorkbook.Path & "\Cekilecek Klasor\" & dosya
    End If
    rs.Close: conn.Close
    dosya = Dir
Loop
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub
Genişletmek için tıkla ...

Tekrar Merhabalar. Farklı Klasör yolu belirttiğimde alım işlemini gerçekleştiremiyorum. örneğin çekmek istediğim dosya 3 alt klasörde. Bu şekilde yapabilmemiz mümkünmüdür
 
ibrahimaliaslan' Alıntı:
Tekrar Merhabalar. Farklı Klasör yolu belirttiğimde alım işlemini gerçekleştiremiyorum. örneğin çekmek istediğim dosya 3 alt klasörde. Bu şekilde yapabilmemiz mümkünmüdür
Genişletmek için tıkla ...

klasör yolunu yazarmısınız?
 
C:\Users\ibrahimA\Desktop\Etutler hocam bu yolu fakat ana excel ve diğer iç içe olan kasörler var etutler klasorunun içinde klasörler var excelde yolunu belirttiğimiz klasörden çekecek o klasörde etütler klasörünün içinde
 
ibrahimaliaslan' Alıntı:
C:\Users\ibrahimA\Desktop\Etutler hocam bu yolu fakat ana excel ve diğer iç içe olan kasörler var etutler klasorunun içinde klasörler var excelde yolunu belirttiğimiz klasörden çekecek o klasörde etütler klasörünün içinde
Genişletmek için tıkla ...

Ana dosya yolu nedir?
 
C:\Users\ibrahimA\Desktop hocam oda masaüstünde dosya adı ANA EXCEL
 
etutler klasorunun içindede zaman içinde farklılık gösteren klasorler var. o klasorlerin iiçindede dosyalar var yani hocam örneğin ;

C:\Users\ibrahimA\Desktop\Etutler\1.asama\montaj\ahmet.xlsm ben böyle yolu giricem oraya.


daha sonra oraya;

C:\Users\ibrahimA\Desktop\2.asama\kaynak\cemal.xlsm

yani C:\Users\ibrahimA\Desktop\Etutler --- buraya kadar sabit sonrası değişken hocam
 
ibrahimaliaslan' Alıntı:
etutler klasorunun içindede zaman içinde farklılık gösteren klasorler var. o klasorlerin iiçindede dosyalar var yani hocam örneğin ;

C:\Users\ibrahimA\Desktop\Etutler\1.asama\montaj\ahmet.xlsm ben böyle yolu giricem oraya.


daha sonra oraya;

C:\Users\ibrahimA\Desktop\2.asama\kaynak\cemal.xlsm

yani C:\Users\ibrahimA\Desktop\Etutler --- buraya kadar sabit sonrası değişken hocam
Genişletmek için tıkla ...

o alt klosörün içinde 1 dosyamı var yoksa birden fazlamı dosya var?
 
Ekli dosyayı inceleyiniz.
Butona basınız,karşınıza çıkacak olan klasörlerden birini seçiniz.Ve tamama basınız.
Not : tüm dosyalarda sayfa adları ayni ve sütun başlıkları ayni olmalı.
 

Ekli dosyalar

Hocam Debug hatası veriyor. örnek klasörleride ekteki dosyada yolluyorum rica etsem bakabilirmisiniz
 

Ekli dosyalar

hocam hep ilk çekilen dosyadaki veriyi alıyor. sonra seçtiğim klasödeki veriyi çekmiyor yine ilk çektiğindeki veriyi getiriyor. sayfaların ilk satırlarını değiştirdim ekte mevcut hocam
 

Ekli dosyalar

ibrahimaliaslan' Alıntı:
hocam hep ilk çekilen dosyadaki veriyi alıyor. sonra seçtiğim klasödeki veriyi çekmiyor yine ilk çektiğindeki veriyi getiriyor. sayfaların ilk satırlarını değiştirdim ekte mevcut hocam
Genişletmek için tıkla ...

Gerekli düzenlemeyi yaptım.
Dosya 16ncı mesajda.
 
Hocam herşey için çok teşekkür ederim başarılarınızın devamını diliyorum çok sağolun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst