Birden Çok Kapalı Excel Dosyasından Veri Alma

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,788
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
merhaba,

kodları inceleyip, kendi ihtiyacıma göre editlemeye çalışıyorum
ama kodların içerisinde kayboldum. ".xls" ile biten tüm dosyaların "sayfa1" sekmesinden
B2'yi A kolonuna,
H8'i B kolonuna,
I8'i C kolonuna yazıyor.

bu hücrelerin ismini hiçbir satırda göremedim.
yani ben aşağıdaki gibi yapabilmek için neyi değiştirmeliyim?

birçok .xls dosyasının "sayfa1" sekmesinden aşağıdaki hücreleri alıp, ana dosyama taşımak istiyorum.

A2 - A kolonuna,
A4 - B kolonuna,
A7 - C kolonuna,
A10 - D kolonuna,
A13 - E kolonuna,
A16 - F kolonuna,
A19 - G kolonuna yazmak istiyorum.

bana yardımcı olabilir misiniz?
Merhaba

Sizin excel seviyenizi bilmiyorum
Kırmızı renkli değerler satır ve sütun numaralarını gösteriyor.

kod:

Kod:
Sub aktar2()
Kaynak = "C:\DENEME"

Application.DisplayAlerts = False

Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If ThisWorkbook.Name <> Dosya.Name Then
deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1
Cells(sat, "A") = ExecuteExcel4Macro(deg & [COLOR="Red"]2[/COLOR] & "C" & [COLOR="red"]1[/COLOR])
Cells(sat, "B") = ExecuteExcel4Macro(deg & [COLOR="red"]4[/COLOR] & "C" & [COLOR="red"]1[/COLOR])
Cells(sat, "C") = ExecuteExcel4Macro(deg & [COLOR="red"]7[/COLOR] & "C" & [COLOR="red"]1[/COLOR])
Cells(sat, "D") = ExecuteExcel4Macro(deg & [COLOR="red"]10[/COLOR] & "C" & [COLOR="red"]1[/COLOR])
Cells(sat, "E") = ExecuteExcel4Macro(deg & [COLOR="red"]13[/COLOR] & "C" & [COLOR="red"]1[/COLOR])
Cells(sat, "F") = ExecuteExcel4Macro(deg & [COLOR="red"]16[/COLOR] & "C" & [COLOR="red"]1[/COLOR])
Cells(sat, "G") = ExecuteExcel4Macro(deg & [COLOR="red"]19[/COLOR] & "C" & [COLOR="red"]1[/COLOR])

End If
Next
Application.ScreenUpdating = True

MsgBox "işlem tamam"

End Sub
Kod:
Cells(sat, "A") = ExecuteExcel4Macro(deg & [COLOR="Red"]2[/COLOR] & "C" & [COLOR="red"]1[/COLOR])
örnek
Yukarıdaki kodda en sağdaki kırmızı renkli ("C" & 1)) sayıları A sütununu göstermekte (& 2 &) iki birleştirme simgesi arasında kalan kırmızı renkli değerlerde satırları göstermekte
 
Katılım
20 Eylül 2011
Mesajlar
32
Excel Vers. ve Dili
Office 365 İngilizce
Altın Üyelik Bitiş Tarihi
06-08-2020
yardımınız ve uğraşınız için teşekkür ederim. kodları inceleyerek nasıl çalıştığı konusunda deneme-yanılma yapacağım.
saygılarımla
 
Katılım
20 Eylül 2011
Mesajlar
32
Excel Vers. ve Dili
Office 365 İngilizce
Altın Üyelik Bitiş Tarihi
06-08-2020
peki bir sorum daha var size halit bey.

Klasör içerisindeki dosyaların isimleriyle(uzantı hariç) sekme isimleri aynı.
örn:
"liste365.xls" dosyası içerisinde tek sekme var, onun da ismi "liste365".
yani hepsinin standart olarak "sayfa1" değil.

deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
Yukardaki "Sayfa1" yerine, "dosya ismi" gibi bişey yapmak mümkün mü?
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,788
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
peki bir sorum daha var size halit bey.

Klasör içerisindeki dosyaların isimleriyle(uzantı hariç) sekme isimleri aynı.
örn:
"liste365.xls" dosyası içerisinde tek sekme var, onun da ismi "liste365".
yani hepsinin standart olarak "sayfa1" değil.



Yukardaki "Sayfa1" yerine, "dosya ismi" gibi bişey yapmak mümkün mü?
Aşağıdaki kod dosyada tek sayfa varsa sayfa seçimini kendi yapıyor ve kod çalışıyor eğer birden fazla sayfa varsa seçim yapmanız gerekiyor.

kod:

Kod:
Sub aktar2()
Kaynak = "C:\DENEME"

Application.DisplayAlerts = False

Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
yer = Cells(1, 1).Value

For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If ThisWorkbook.Name <> Dosya.Name Then


deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & X & "'!R"
Cells(1, 1).Value = "=" & deg & 1 & "C" & 1

Cells(1, 1).Replace What:="=", Replacement:=""
alan1 = Cells(1, 1).Value
alan2 = Right(alan1, InStr(1, StrReverse(alan1), "]", vbTextCompare))
alan3 = Right(alan2, InStr(1, StrReverse(alan2), "!", vbTextCompare))
SayfaAdi = Mid(alan2, 2, Len(alan2) - Len(alan3) - 2)
Cells(1, 1).Value = SayfaAdi
SayfaAdi = "Sayfa1"

deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & SayfaAdi & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
'deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1
Cells(sat, "A") = ExecuteExcel4Macro(deg & 2 & "C" & 1)
Cells(sat, "B") = ExecuteExcel4Macro(deg & 4 & "C" & 1)
Cells(sat, "C") = ExecuteExcel4Macro(deg & 7 & "C" & 1)
Cells(sat, "D") = ExecuteExcel4Macro(deg & 10 & "C" & 1)
Cells(sat, "E") = ExecuteExcel4Macro(deg & 13 & "C" & 1)
Cells(sat, "F") = ExecuteExcel4Macro(deg & 16 & "C" & 1)
Cells(sat, "G") = ExecuteExcel4Macro(deg & 19 & "C" & 1)

End If
Next
Cells(1, 1).Value = yer
Application.ScreenUpdating = True

MsgBox "işlem tamam"

End Sub
 
Katılım
20 Eylül 2011
Mesajlar
32
Excel Vers. ve Dili
Office 365 İngilizce
Altın Üyelik Bitiş Tarihi
06-08-2020
Aşağıdaki kod dosyada tek sayfa varsa sayfa seçimini kendi yapıyor ve kod çalışıyor eğer birden fazla sayfa varsa seçim yapmanız gerekiyor.

kod:

Kod:
Sub aktar2()
Kaynak = "C:\DENEME"

Application.DisplayAlerts = False

Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
yer = Cells(1, 1).Value

For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If ThisWorkbook.Name <> Dosya.Name Then


deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & X & "'!R"
Cells(1, 1).Value = "=" & deg & 1 & "C" & 1

Cells(1, 1).Replace What:="=", Replacement:=""
alan1 = Cells(1, 1).Value
alan2 = Right(alan1, InStr(1, StrReverse(alan1), "]", vbTextCompare))
alan3 = Right(alan2, InStr(1, StrReverse(alan2), "!", vbTextCompare))
SayfaAdi = Mid(alan2, 2, Len(alan2) - Len(alan3) - 2)
Cells(1, 1).Value = SayfaAdi
SayfaAdi = "Sayfa1"

deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & SayfaAdi & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
'deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1
Cells(sat, "A") = ExecuteExcel4Macro(deg & 2 & "C" & 1)
Cells(sat, "B") = ExecuteExcel4Macro(deg & 4 & "C" & 1)
Cells(sat, "C") = ExecuteExcel4Macro(deg & 7 & "C" & 1)
Cells(sat, "D") = ExecuteExcel4Macro(deg & 10 & "C" & 1)
Cells(sat, "E") = ExecuteExcel4Macro(deg & 13 & "C" & 1)
Cells(sat, "F") = ExecuteExcel4Macro(deg & 16 & "C" & 1)
Cells(sat, "G") = ExecuteExcel4Macro(deg & 19 & "C" & 1)

End If
Next
Cells(1, 1).Value = yer
Application.ScreenUpdating = True

MsgBox "işlem tamam"

End Sub
tekrar merhaba Halit bey,
öncelikle ilginiz, yardımınız için ne kadar teşekkür etsem az. sağolun.

ama ben bu kodu çalıştıramadım.
ikinci gönderdiğiniz kodu aktar2 butonuna kaydettim. hata alıyorum. dosyayı ekledim.
 

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,788
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
tekrar merhaba Halit bey,
öncelikle ilginiz, yardımınız için ne kadar teşekkür etsem az. sağolun.

ama ben bu kodu çalıştıramadım.
ikinci gönderdiğiniz kodu aktar2 butonuna kaydettim. hata alıyorum. dosyayı ekledim.
Kod bende çalışıyor

Aşağıdaki klasör yolunu kontrol ediniz burada ilgili klasör varmı?

Kod:
Kaynak = "D:\RAPOR\Saha\Karışık Rapor\rapor\[COLOR="Red"]dosyalar[/COLOR]"
 
Katılım
1 Mayıs 2011
Mesajlar
42
Excel Vers. ve Dili
2003 türkçe
Sub auto_open()( buton yardımıyla getirmesi)
Sayfa1.Range("a2:R1000").ClearContents
Dim con As Object, evn As Object, yol As String
yol = "\sedat"( dosya içinde bulunan Sedat, kadir alico,İslam ve dahasonra ekleyecim dosyaların tamamı alması )
en son olarak veri altında bütün sütünları toplamı alması

örnek dosya ekte

Sub auto_open()
Sayfa1.Range("a2:R47").ClearContents
Dim con As Object, evn As Object, yol As String
yol = "\sedat"
Set evn = CreateObject("scripting.filesystemobject")
Set klasor = evn.getfolder(ThisWorkbook.Path & yol)
For Each xls In klasor.Files
If UCase(VBA.Right(xls.Name, 3)) = "XLS" Then
Set con = CreateObject("adodb.connection")
con.Open " provider=microsoft.jet.oledb.4.0;data source=" & xls.Path & ";extended properties=""excel 8.0;hdr=no"""
Range("a65534").End(3)(2, 1).Value = con.Execute("select * from [sayfa1$B1:B1]").fields(0).Value
Range("a65534").End(3)(1, 2).Value = con.Execute("select * from [sayfa1$C1:C1]").fields(0).Value
Range("a65536").End(3)(1, 3).Value = con.Execute("select * from [sayfa1$D1:D1]").fields(0).Value
Range("a65536").End(3)(1, 4).Value = con.Execute("select * from [sayfa1$G1:G1]").fields(0).Value
Range("a65536").End(3)(1, 5).Value = con.Execute("select * from [sayfa1$I1:I1]").fields(0).Value
Range("a65536").End(3)(1, 6).Value = con.Execute("select * from [sayfa1$J1:J1]").fields(0).Value
Range("a65536").End(3)(1, 7).Value = con.Execute("select * from [sayfa1$O2:O2]").fields(0).Value
Range("a65536").End(3)(1, 8).Value = con.Execute("select * from [sayfa1$O3:O3]").fields(0).Value
Range("a65536").End(3)(1, 9).Value = con.Execute("select * from [sayfa1$O4:O4]").fields(0).Value
Range("a65536").End(3)(1, 10).Value = con.Execute("select * from [sayfa1$O5:O5]").fields(0).Value
Range("a65536").End(3)(1, 11).Value = con.Execute("select * from [sayfa1$O6:O6]").fields(0).Value
Range("a65536").End(3)(1, 12).Value = con.Execute("select * from [sayfa1$O7:O7]").fields(0).Value
Range("a65536").End(3)(1, 13).Value = con.Execute("select * from [sayfa1$O8:O8]").fields(0).Value
Range("a65536").End(3)(1, 14).Value = con.Execute("select * from [sayfa1$O9:O9]").fields(0).Value
Range("a65536").End(3)(1, 15).Value = con.Execute("select * from [sayfa1$O10:O10]").fields(0).Value
Range("a65536").End(3)(1, 16).Value = con.Execute("select * from [sayfa1$O11:O11]").fields(0).Value
Range("a65536").End(3)(1, 17).Value = con.Execute("select * from [sayfa1$O12:O12]").fields(0).Value
Range("a65536").End(3)(1, 18).Value = con.Execute("select * from [sayfa1$O13:O13]").fields(0).Value
Range("a65536").End(3)(1, 19).Value = con.Execute("select * from [sayfa1$O14:O14]").fields(0).Value
Range("a65536").End(3)(1, 20).Value = con.Execute("select * from [sayfa1$O15:O15]").fields(0).Value
Range("a65536").End(3)(1, 21).Value = con.Execute("select * from [sayfa1$O16:O16]").fields(0).Value
Range("a65536").End(3)(1, 22).Value = con.Execute("select * from [sayfa1$P17:p17]").fields(0).Value
Range("a65536").End(3)(1, 23).Value = con.Execute("select * from [sayfa1$P18:p18]").fields(0).Value
Range("a65536").End(3)(1, 24).Value = con.Execute("select * from [sayfa1$P19:p19]").fields(0).Value
Range("a65536").End(3)(1, 25).Value = con.Execute("select * from [sayfa1$N20:N20]").fields(0).Value
Range("a65536").End(3)(1, 26).Value = con.Execute("select * from [sayfa1$N21:N21]").fields(0).Value
Range("a65536").End(3)(1, 27).Value = con.Execute("select * from [sayfa1$N22:N21]").fields(0).Value
Range("a65536").End(3)(1, 28).Value = con.Execute("select * from [sayfa1$N23:N23]").fields(0).Value
Range("a65536").End(3)(1, 29).Value = con.Execute("select * from [sayfa1$O24:O25]").fields(0).Value
Range("a65536").End(3)(1, 30).Value = con.Execute("select * from [sayfa1$O25:O25]").fields(0).Value
Range("a65536").End(3)(1, 31).Value = con.Execute("select * from [sayfa1$O26:O26]").fields(0).Value

End If
Next xls
con.Close: yol = vbNullString
Set rs = Nothing: Set con = Nothing
Set evn = Nothing: Set klasor = Nothing: Set xls = Nothing
End Sub


şimdiden teşeküğr ederim....
 

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,788
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Sub auto_open()( buton yardımıyla getirmesi)
Sayfa1.Range("a2:R1000").ClearContents
Dim con As Object, evn As Object, yol As String
yol = "\sedat"( dosya içinde bulunan Sedat, kadir alico,İslam ve dahasonra ekleyecim dosyaların tamamı alması )
en son olarak veri altında bütün sütünları toplamı alması
şimdiden teşeküğr ederim....
Soru bütünlüğü bozulmaması için sorunuzu yeni bir konu açarak farklı bir başlık altında sorun

Buradaki sorunuzu da takip edenler için karışıklık olmaması dileğiyle silin.
 
Katılım
1 Mayıs 2011
Mesajlar
42
Excel Vers. ve Dili
2003 türkçe
cari hesap

halit bey selamlar
daha önce yapmış oldugunuz çalışma
acaba Alacak&Verecek Raporunda kişilerin üzerine tıkladığın kişiye ait dosyayı açması münkünmüdür
selamlar
 

Ekli dosyalar

Son düzenleme:

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,788
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
halit bey selamlar
daha önce yapmış oldugunuz çalışma
acaba Alacak&Verecek Raporunda kişilerin üzerine tıkladığın kişiye ait dosyayı açması münkünmüdür
selamlar
Sorunuz içinde makro kodu varsa mesaj yazdığınız yerin hemen üstünde
# bu işaret var. işarete tıklayınca
(CODE] Kodlarınızı bu araya yazın [/CODE)

Mesajınızdaki kodları yukarıdaki söylediğim gibi düzeltin sorunuza o zaman bakalım.
 
Katılım
1 Mayıs 2011
Mesajlar
42
Excel Vers. ve Dili
2003 türkçe
veri alma köprü oluşturması

halit bey selamlar
daha önce yapmış oldugunuz çalışma
acaba Alacak&Verecek Raporunda kişilerin üzerine tıkladığın kişiye ait dosyayı açması münkünmüdür
selamlar
Kod:
Sub aktar()
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
sat1 = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Liste (ThisWorkbook.Path)
MsgBox "İŞLEM TAMAM"
End Sub
Private Sub Liste(Kalasor As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Kalasor).subfolders
Dim wb As Workbook
Dosya = Dir(Kalasor & "\*.xls")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
deg = "'" & Kalasor & "\" & "[" & Dosya & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1
Cells(sat, 1) = ExecuteExcel4Macro(deg & 2 & "C2")
Cells(sat, 2) = ExecuteExcel4Macro(deg & 8 & "C8")
Cells(sat, 3) = ExecuteExcel4Macro(deg & 8 & "C9")

End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,788
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
halit bey selamlar
daha önce yapmış oldugunuz çalışma
acaba Alacak&Verecek Raporunda kişilerin üzerine tıkladığın kişiye ait dosyayı açması münkünmüdür
selamlar

kod:
Kod:
Sub aktar()
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
sat1 = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Hyperlinks.Delete


Liste (ThisWorkbook.Path)
MsgBox "İŞLEM TAMAM"
End Sub
Private Sub Liste(Kalasor As String)
Dim fL As Object, f As Object, Dosya As String, j As Long

Set fL = CreateObject("Scripting.FileSystemObject")


Dim wb As Workbook
Dosya = Dir(Kalasor & "\*.xls")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
deg = "'" & Kalasor & "\" & "[" & Dosya & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1

Cells(sat, 1) = ExecuteExcel4Macro(deg & 2 & "C2")

Cells(sat, 1).Hyperlinks.Add Anchor:=Cells(sat, 1), Address:=Kalasor & "\" & Dosya, TextToDisplay:=fL.GetBaseName(Dosya)


Cells(sat, 2) = ExecuteExcel4Macro(deg & 8 & "C8")
Cells(sat, 3) = ExecuteExcel4Macro(deg & 8 & "C9")

End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL.GetFolder(Kalasor).subfolders
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub
 
Katılım
1 Mayıs 2011
Mesajlar
42
Excel Vers. ve Dili
2003 türkçe
halit bey tşk.

halit bey selamlar yaptığınız calışma için cok teşekür ederim..
 
Son düzenleme:

yuemse

Altın Üye
Katılım
28 Eylül 2010
Mesajlar
75
Excel Vers. ve Dili
2016 excel türkçe
Altın Üyelik Bitiş Tarihi
06-04-2025
teşekkürler
 

yuemse

Altın Üye
Katılım
28 Eylül 2010
Mesajlar
75
Excel Vers. ve Dili
2016 excel türkçe
Altın Üyelik Bitiş Tarihi
06-04-2025
Halit Hocam bu koda istediğimiz dosya yolu verebilir miyiz

kod:
Kod:
Sub aktar()
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
sat1 = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Hyperlinks.Delete


Liste (ThisWorkbook.Path)
MsgBox "İŞLEM TAMAM"
End Sub
Private Sub Liste(Kalasor As String)
Dim fL As Object, f As Object, Dosya As String, j As Long

Set fL = CreateObject("Scripting.FileSystemObject")


Dim wb As Workbook
Dosya = Dir(Kalasor & "\*.xls")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
deg = "'" & Kalasor & "\" & "[" & Dosya & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1

Cells(sat, 1) = ExecuteExcel4Macro(deg & 2 & "C2")

Cells(sat, 1).Hyperlinks.Add Anchor:=Cells(sat, 1), Address:=Kalasor & "\" & Dosya, TextToDisplay:=fL.GetBaseName(Dosya)


Cells(sat, 2) = ExecuteExcel4Macro(deg & 8 & "C8")
Cells(sat, 3) = ExecuteExcel4Macro(deg & 8 & "C9")

End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL.GetFolder(Kalasor).subfolders
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub
 

yuemse

Altın Üye
Katılım
28 Eylül 2010
Mesajlar
75
Excel Vers. ve Dili
2016 excel türkçe
Altın Üyelik Bitiş Tarihi
06-04-2025
Dosya veya dosyalara ait klasör yolu kodun bu bölümü.

Kod:
Liste ([COLOR="Red"]ThisWorkbook.Path[/COLOR])
Hocam 3 4 klasör var ben bir tanesinin içindeki excel dosyalarını listelesin istiyorum. Diğer kodu denedim ama bu kodda aranan dosyanın uzantısını ayarlayabiliyoruz ve hyperlink atıyabiliyoruz o yüzden bu kodu seçtim. Yardımınız için şimdiden teşekkürler.
 
Son düzenleme:

yuemse

Altın Üye
Katılım
28 Eylül 2010
Mesajlar
75
Excel Vers. ve Dili
2016 excel türkçe
Altın Üyelik Bitiş Tarihi
06-04-2025
Liste (ThisWorkbook.Path)
dosya yolunu buraya yazınca oldu
 
Üst