• DİKKAT

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

Bir klasör içindeki tüm excel dosyalarını listeleme

H

huseyin610

Katılım
1 Ekim 2004
Mesajlar
206
Merhaba,

C:\deneme klasörümüz var.Bunun içinde sayısı devamlı artan aynı formata sahip tek sayfalı xls dosyaları oluşturuyoruz.Liste adlı ayrı bir excel dosyamızın I. sayfasında deneme klasörü içerisindeki tüm xls dosyalarının adlarının listelenmesi (dosyaya köprü atanmış olarak) ve dosya isimlerinin karşısına sözkonusu dosya içerisindeki H1 ve I1 hücresindeki değerlerin gelmesini sağlayacak bir makro yazılabilir mi ? Dosya isimleri A sütununa, H1 hücresindeki değerler B sütununa , I1 hücresindeki değerler C sütununa yazılabilir.


Saygılarımla,
 
ekli dosyaya bir bakınız.
 

Ekli dosyalar

başka bir kodda var ekliyorum.


Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim baslangıc As String
Sub bul()
sat1 = Cells(Rows.Count, "A").End(3).Row - 1
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.browseforfolder(0, Baslik, 50, &H0)
Kaynak = Klasor.Items.Item.Path

If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
baslangıc = Application.InputBox("Veri Alınacak Başlangıç satırı yazınız.", "Veri Alınacak Başlangıç satır no", "xls", 400, 30)
Call Liste(Kaynak, "")
Application.DisplayAlerts = False
Range("A1").Select
sat = Cells(Rows.Count, "A").End(3).Row - 1
MsgBox sat - sat1 & " adet dosya bulundu işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub
Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfold er(Klasor).SubFolders
Dim wb As Workbook
Uzanti = baslangıc
Dosya = Dir(Klasor & "\*.**" & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
sat = [a65000].End(3).Row + 1
Cells(sat, "A").Value = Klasor & "\" & Dosya
deg = "'" & Klasor & "\[" & Dosya & "]" & x & "'!R"
Application.StatusBar = Yol
Cells(sat, 1).Value = Klasor & "\" & Dosya
Cells(sat, 1).Hyperlinks.Add Anchor:=Cells(sat, 1), Address:=Klasor & "\" & Dosya, TextToDisplay:=Dosya
On Error Resume Next
Cells(sat, 2).Value = "=" & deg & 1 & "C" & 1
Cells(sat, 2).Replace What:="=", Replacement:=""
alan1 = Worksheets(ActiveSheet.Name).Cells(sat, 2).Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
zaman = Mid(alan1, k + 1, yer)
End If
Next
If zaman = "" Then
Cells(sat, 2).Value = Mid(Dosya, 1, Len(Dosya) - 4)
End If
Cells(sat, 2).Value = zaman
sayfaadi = zaman
If sayfaadi = "" Then
sayfaadi = 1
Else
sayfaadi = sayfaadi
End If
On Error Resume Next
deg = "'" & Klasor & "\[" & Dosya & "]" & Cells(sat, 2).Value & "'!R"
Cells(sat, "b").Value = ExecuteExcel4Macro(deg & 1 & "C8")
Cells(sat, "C").Value = ExecuteExcel4Macro(deg & 1 & "C9")
sat = sat + 1
End If
Dosya = Dir
Wend

On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
'Liste (f.path)
Call Liste(Kaynak, "")
sonraki:
Next
Set fL = Nothing
End Sub
Genişletmek için tıkla ...
 
Halit Bey Merhaba,


I. göndermiş olduğunuz dosya tam istediğim gibi ,sadece dosya yolunu seçmeme gerek yok her seferinde C:\CARİ\CARİ şeklinde , bir de D sütununa klasör içindeki excel dosyalarının A:A Sütununda son satıra girilen tarih değerlerinin listelenmesi istiyorum.Yardımcı olursanız mükemmel olacak. Saygılarımla..
 
huseyin610' Alıntı:
Halit Bey Merhaba,


I. göndermiş olduğunuz dosya tam istediğim gibi ,sadece dosya yolunu seçmeme gerek yok her seferinde C:\CARİ\CARİ şeklinde , bir de D sütununa klasör içindeki excel dosyalarının A:A Sütununda son satıra girilen tarih değerlerinin listelenmesi istiyorum.Yardımcı olursanız mükemmel olacak. Saygılarımla..
Genişletmek için tıkla ...

bunu denermisiniz. ancak a sütunundaki hücrelerde boş olmuyacak dolu en son veriyi getiriyor.

Kod: 
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Sub bul()
Kaynak = "D:\CARİ\CARİ" 'Buraya dosya yolunu yazacaksınız.
Call Liste(Kaynak, "")
End Sub
Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").getfolder(Klasor).SubFolders
Dim wb As Workbook
Uzanti = "xls"
Dosya = Dir(Klasor & "\*.**" & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
sat = [a65000].End(3).Row + 1
Cells(sat, "A").Value = Klasor & "\" & Dosya
deg = "'" & Klasor & "\[" & Dosya & "]" & x & "'!R"
Application.StatusBar = Yol
On Error Resume Next
Cells(sat, "b").Value = "=" & deg & 1 & "C" & 1
Cells(sat, "b").Replace What:="=", Replacement:=""
alan1 = Worksheets(ActiveSheet.Name).Cells(sat, "b").Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
zaman = Mid(alan1, k + 1, yer)
End If
Next
If zaman = "" Then
Cells(sat, "b").Value = Mid(Dosya, 1, Len(Dosya) - 4)
End If
Cells(sat, "b").Value = zaman
sayfaadi = zaman
If sayfaadi = "" Then
sayfaadi = 1
Else
sayfaadi = sayfaadi
End If
On Error Resume Next
deg = "'" & Klasor & "\[" & Dosya & "]" & Cells(sat, "b").Value & "'!R"
sat1 = Application.ExecuteExcel4Macro("COUNTA('" & Klasor & "\[" & Dosya & "]" & Cells(sat, "b").Value & "'!R1C1:R" & Rows.Count & "C1)") 'san satır
Cells(sat, "a").Value = Klasor & "\" & Dosya
Cells(sat, "a").Hyperlinks.Add Anchor:=Cells(sat, "a"), Address:=Klasor & "\" & Dosya, TextToDisplay:=Dosya
Cells(sat, "b").Value = ExecuteExcel4Macro(deg & 1 & "C8")
Cells(sat, "c").Value = ExecuteExcel4Macro(deg & 1 & "C9")
Cells(sat, "d").Value = ExecuteExcel4Macro(deg & sat1 & "C1") ' burası san satırdaki dolu değeri getiriyor.
sat = sat + 1
End If
Dosya = Dir
Wend

On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Call Liste(Kaynak, "")
sonraki:
Next
Set fL = Nothing
End Sub
 
a sütununa en alt satırdan baktıramaz mıyız ? Çünkü üs taraftan kontrol edilince arada boş satırlar var.Yani şu şekilde kontrol etse kod ; a sütununda en alt satırdan yukarıya doğru ilk dolu satır
 
huseyin610' Alıntı:
a sütununa en alt satırdan baktıramaz mıyız ? Çünkü üs taraftan kontrol edilince arada boş satırlar var.Yani şu şekilde kontrol etse kod ; a sütununda en alt satırdan yukarıya doğru ilk dolu satır
Genişletmek için tıkla ...

şimdi yukarıdaki mesajdaki kod dosyayı açmadan son satırı buluyordu
bu kod dosyaları açıp son satırı buluyor ve kapatıyor

Kod: 
Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Sub bul()
Kaynak = "D:\CARİ\CARİ" 'Buraya dosya yolunu yazacaksınız.
Call Liste(Kaynak, "")
End Sub
Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).SubFolders
Dim wb As Workbook
Uzanti = "xls"
Dosya = Dir(Klasor & "\*.**" & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
sat = [a65000].End(3).Row + 1
Cells(sat, "A").Value = Klasor & "\" & Dosya
deg = "'" & Klasor & "\[" & Dosya & "]" & x & "'!R"
Application.StatusBar = Yol
On Error Resume Next
Cells(sat, "b").Value = "=" & deg & 1 & "C" & 1
Cells(sat, "b").Replace What:="=", Replacement:=""
alan1 = Worksheets(ActiveSheet.Name).Cells(sat, "b").Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
zaman = Mid(alan1, k + 1, yer)
End If
Next
If zaman = "" Then
Cells(sat, "b").Value = Mid(Dosya, 1, Len(Dosya) - 4)
End If
Cells(sat, "b").Value = zaman
sayfaadi = zaman
If sayfaadi = "" Then
sayfaadi = 1
Else
sayfaadi = sayfaadi
End If
On Error Resume Next
deg = "'" & Klasor & "\[" & Dosya & "]" & Cells(sat, "b").Value & "'!R"
sat1 = Application.ExecuteExcel4Macro("COUNTA('" & Klasor & "\[" & Dosya & "]" & Cells(sat, "b").Value & "'!R1C1:R" & Rows.Count & "C1)") 'san satır

Set wb = Workbooks.Open(Klasor & "\" & Dosya)
yeni_dosya_adı = ActiveWorkbook.Name
Windows(wb.Name).Visible = False
sayfaadi = Workbooks(yeni_dosya_adı).Sheets(1).Name
satır = Workbooks(yeni_dosya_adı).Sheets(sayfaadi).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Windows(wb.Name).Visible = True
wb.Close False

Cells(sat, "a").Value = Klasor & "\" & Dosya
Cells(sat, "a").Hyperlinks.Add Anchor:=Cells(sat, "a"), Address:=Klasor & "\" & Dosya, TextToDisplay:=Dosya
Cells(sat, "b").Value = ExecuteExcel4Macro(deg & 1 & "C8")
Cells(sat, "c").Value = ExecuteExcel4Macro(deg & 1 & "C9")
Cells(sat, "d").Value = ExecuteExcel4Macro(deg & satır & "C1") ' burası san satırdaki dolu değeri getiriyor.
sat = sat + 1
End If
Dosya = Dir
Wend

On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Call Liste(Kaynak, "")
sonraki:
Next
Set fL = Nothing
End Sub
 
Konu ile ilgili bir sorum olacaktı. Eğer Halit Bey bakabilirseniz sevinirim.

Aratıyoruz dosyalara köprü konuyor, o bölümde eğerki eexcel dosyası ise bulduğu çalışma sayfası seçmemiz gerekiyor burayı otomatik olarak geçebilirmi?

ayrıca boyutunun ne olduğu yanına eklenebilirmi?

Teşekkürler
 
deg = "'" & Klasor & "\[" & Dosya & "]" & x & "'!R"
Genişletmek için tıkla ...

buradaki x değeri yerine "Sayfa1" olarak değiştirirseniz sayfa1 deki verileri alırsınız.
 
halit3

Hocam iyi günler buraya yazmış olduğunuz kod ile seçtiğim klasördeki exel dosyalarının isimlerinin listesini alabildim. aynı zamanda köprü de var her bi dosya için çok teşekkürler. sizden ricam ben bi özellik daha eklemek istiyorum yardımcı olabilirmisiniz acaba bana , o gelen her bi exel dosyasının içinde H4 hücresinde ve K1 hücresindeki verileride yan listelediğim exelde hemen yan hücresine gertirtebilirmiyiz. yani bu koda nasıl bi ekleme yapmamız gerekir. yardımcı olursanız eğer çok sevinirim iyi günler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst