Soru Konumları bilinen çok sayıda dosyayı sırayla açmak

[seckinb]

Merhaba

e:\......\0111.xlsm
gibi tam yoluna sahip olduğum 150-200 dosyayı kod yardımıyla tek tek açıp düzenlemek istiyorum.

tüm listeyi kolayca import edip nasıl açabilirim?

hepsini aynı anda değilde, kapattıkça bir diğeri açılacak şekilde yapmam lazım

D:\EDU\TRT\LU177_TATE\0113_AYSEL GÜNGÖR\0113_AYSEL GÜNG .xlsm

D:\EDU\TRT\LU177_TATE\0114_ALPAR DADAŞ BILGE\0114_ALPAR DAD BILGE.xlsm

D:\EDU\TRT\LU177_TATE\0115_İBRAHIM ÇEVIK\0115_İBRAHIM ÇEV.xlsm

 

[PLİNT]

Merhaba
Aşağıdaki kodları deneyiniz
https://www.dosyaupload.com/jtaE
"Başla" butonu ile açılan "D" diski penceresinden "EDU" klasörünü seçtiğinizde alt kasörlerde olanlarda dahil, düzenlediğiniz dosyayı kapattıkça yenisi açılacaktır.

Private Sub CommandButton1_Click()
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
Erase lst: sy = 0
ReDim lst(0)
Set klasorsec = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör seçiniz", 0, "D:\")
If klasorsec Is Nothing Then Exit Sub
yol = klasorsec.Items.Item.Path
If IsEmpty(yol) = True Then Exit Sub
Set klr = a.getfolder(yol)
For Each dsy In klr.Files
If a.GetExtensionName(dsy.Name) Like "xls*" Then
say = say + 1
ReDim Preserve lst(say)
lst(say) = dsy
End If
Next
n = 1
dic.Add n, yol
geri:
h = dic.Count
On Error Resume Next
For j = n To h
Set klasor = a.getfolder(dic(j))
 If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
For Each dosya In alt.Files
If a.GetExtensionName(dosya.Name) Like "xls*" Then
say = say + 1
ReDim Preserve lst(say)
lst(say) = alt & "\" & dosya.Name
End If
Next
dic.Add dic.Count + 1, alt
Next:
End If:
Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If

If UBound(lst) <> 0 Then Call bkm
End Sub

Bir modül ekleyip

Public lst(), sy As Long
Private g
Sub bkm()
f = 1
For Each r In Application.Workbooks
If r.FullName = lst(sy) Then f = 2
Next
If UBound(lst) <= sy Then
Call dur
Exit Sub
End If
If f = 1 Then
sy = sy + 1
Workbooks.Open lst(sy)
End If
g = Now + TimeSerial(0, 0, 1)
Application.OnTime g, "bkm", , True
End Sub
Sub dur()
On Error Resume Next
If g <> Empty Then
Application.OnTime g, "bkm", , False
g = Empty
End If
End Sub

 

[seckinb]

çok güzel çalışıyor. Elinize sağlık.