aynı kodu, farklı kalsör adı ile tekrarlama

[euphrates55]

Public bekle
Sub GetSheets()
bekle = "dur"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Path = ThisWorkbook.Path & "\İLLER\AMASYA\"
Filename = Dir(Path & "*.xlsx")
  Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
     For Each Sheet In ActiveWorkbook.Sheets
     ActiveSheet.Name = ActiveSheet.Range("v1")
     Sheet.Copy After:=ThisWorkbook.Sheets(1)
  Next Sheet
     Workbooks(Filename).Close
     Filename = Dir()
  Loop
bekle = ""
MsgBox "Birleştirme Tamamlandı", vbInformation
End Sub

iller adında bir klasörüm var ve altında da amasya çorum samsun ....... vs adında 6 klasörüm var. sorum bunların içindeki excelleri bir seferde birleştirebilmem için
Path = ThisWorkbook.Path & "\İLLER\AMASYA\" kısmını çorum vs değiştirerek kodu tekrarlatmak için ne yapmalıyım. ya da alt klasörler dahil exceli tek dosyada birleştirme şansım var mı? diğer bir sorum ise public bekle tam olarak ne işe yarıyor. (sağdan soldan bir şeyler yapmaya çalışınca muhtemelen gereksiz bir çok kod yazıyorumdur)

 

[askm]

Aşağıdaki şekilde deneyin.

Public Fso As Object, Evn As Object, Dosya As Object
Public Klasörler As Object, Sat As Long

Sub Dizindeki_Tüm_Klasörleri_Tara()
    Call Ara(ThisWorkbook.Path)
    On Error Resume Next
    Set Fso = Nothing: Set Evn = Nothing: Sat = Empty
    Set Dosya = Nothing: Set Klasörler = Nothing
End Sub

Public Function Ara(ByVal Dizin As String)
On Error Resume Next
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Evn = Fso.GetFolder(Dizin): Ara = 0
    For Each Klasörler In Evn.Subfolders
        For Each Dosya In Klasörler.Files
            If Right(Dosya.Name, 5) = ".xlsx" Then
                Workbooks.Open Filename:=Dosya, ReadOnly:=True
                For Each Sheet In ActiveWorkbook.Sheets
                    ActiveSheet.Name = ActiveSheet.Range("v1")
                    Sheet.Copy After:=ThisWorkbook.Sheets(1)
                Next Sheet
                Workbooks(Dosya.Name).Close
            End If
        Next Dosya
        Ara = Ara + 1 + Ara(Klasörler.Path)
    Next Klasörler
End Function

 

[euphrates55]

yazdıklarınızı bir modüle kopyaladım, Dizindeki_Tüm_Klasörleri_Tara ismi ile makro atadım ve bastım. yanlış işlem uygulamadıysam, sonuç tepki yok.

 

[askm]

xls olarak düşünmüştüm.
If Right(Dosya.Name, 4) = ".xlsx" Then olarak bırakmışım.
If Right(Dosya.Name, 5) = ".xlsx" Then olacak kodu düzelttim.
Yalnız sayfa ismini v1 den aldığı için birleştirilecek sayfalarda v1 dolu olması gerekli ve benzersiz olmalı.
Yukardaki kodu düzelttim.

 

[euphrates55]

süpere yakın oldu neden diyeceksiniz, söyleyeyim hemen. excel dosyaları tek tek açılıyor ve kapanmıyor, dolayısı ile hem pc kasmaya başlıyor hem de tek tek kapatmak gerekiyor. açılıp kopyalama yaptıktan sonra kapanırsa ve güncellim mi kaydedim mi şunu yapayım mı diye şeyler sormazsa süper olacak bir de nereden geliyorsa _fill adı zaten var gibi uyarılar geliyor muhtemelen her sayfada var ve bayağı zaman alıyor bunları cevaplamak tabi bu sanırım benimle alakalı. bir yerden gelmiş olmalı. elinize sağlık. teşekkürler...

 

[askm]

Kodu tekrar güncelledim.

 

[euphrates55]

Kodu tekrar güncelledim.

benden de

Application.ScreenUpdating = False
Application.DisplayAlerts = False
end sub

gelsin ama nedendir bilinmez ilk 6 7 dosya kaydet kaydetme uyarısı çıktı. sonrakilerde çıkmadı. sonuç tüm dosyalar kopyalandı. sağolun varolun...

 

[euphrates55]

Public Fso As Object, Evn As Object, Dosya As Object
Public Klasörler As Object, Sat As Long

Sub Dizindeki_Tüm_Klasörleri_Tara()
On Error Resume Next
    Call Ara(ThisWorkbook.Path)
    Set Fso = Nothing: Set Evn = Nothing: Sat = Empty
    Set Dosya = Nothing: Set Klasörler = Nothing
End Sub

Public Function Ara(ByVal Dizin As String)
On Error Resume Next
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Evn = Fso.GetFolder(Dizin): Ara = 0
    For Each Klasörler In Evn.Subfolders
        For Each Dosya In Klasörler.Files
            If Right(Dosya.Name, 5) = ".xlsx" Then
                Workbooks.Open Filename:=Dosya, ReadOnly:=True
                For Each Sheet In ActiveWorkbook.Sheets
                    ActiveSheet.Name = ActiveSheet.Range("v1")
                    Sheet.Copy After:=ThisWorkbook.Sheets(1)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
                Next Sheet
                Workbooks(Dosya.Name).Close
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
            End If
        Next Dosya
        Ara = Ara + 1 + Ara(Klasörler.Path)
    Next Klasörler
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False

MsgBox "Birleştirme Tamamlandı", vbInformation

End Function

Tüm işlemler bittiğinde MsgBox "Birleştirme Tamamlandı", vbInformation bu mesaj kodunu nereye yazacağım. kopyalanacak dosyaların olduğu her klasör tamamlanınca ayrı ayrı uyarı veriyor.

 

[askm]

Yukarıda end sub dan önce.