• DİKKAT

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

Kapalı Dosyadan Veri Alırken Boş Hücreyi Dikkate Alsın

B

Barfly

Katılım
29 Eylül 2007
Mesajlar
136
Excel Vers. ve Dili
Microsoft Office Professional Plus 2026 - Türkçe
Herkese selam,

Aşağıdaki kodu siteden bulup kendime uyarlamaya çalıştım emeği geçenlere teşekkürler. Amacım birden fazla excel dosyasında bulunan İŞ AKIŞI sayfasından tüm verileri alıp yeni bir çalışma sayfasında alt alta getirebilmek. Aşağıdaki kod kısmen işimi görüyor fakat hücre boşsa dikkate almıyor aktarma yapmıyor aslında ben ne görürse aynen getirsin istiyorum buna göre uyarlama yapılabilir mi yardımcı olursanız sevinirim.

Kod: 
Sub VERİLERİ_GÜNCELLE()
    Application.ScreenUpdating = False
    Dosya_Yolu = "C:\Documents and Settings\Mustafa Çakıroğlu\Desktop\Tiryaki\Firmalar\Operasyonlar"
    Set S1 = Workbooks("Operasyon Takibi.xlsm").Sheets("Süreç")
    S1.Select
    [A5:A65536].ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    For Each Dosya In Klasör
    If InStr(Dosya.Name, ".xlsm") > 0 Then
    If Dosya.Name <> "Operasyon Takibi.xlsm" Then
    Workbooks.Open Filename:=Dosya
    Sheets("İŞ AKIŞI").Select
    Range("A5:A" & [A65536].End(3).Row).Copy S1.Cells(65536, 1).End(3).Offset(1)
    Range("B5:B" & [B65536].End(3).Row).Copy S1.Cells(65536, 2).End(3).Offset(1)
    Range("C5:C" & [C65536].End(3).Row).Copy S1.Cells(65536, 3).End(3).Offset(1)
    Range("D5:D" & [D65536].End(3).Row).Copy S1.Cells(65536, 4).End(3).Offset(1)
        
    ActiveWorkbook.Close True
    End If
    End If
    Next
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Teşekkürler,
 
Barfly' Alıntı:
Herkese selam,

Aşağıdaki kodu siteden bulup kendime uyarlamaya çalıştım emeği geçenlere teşekkürler. Amacım birden fazla excel dosyasında bulunan İŞ AKIŞI sayfasından tüm verileri alıp yeni bir çalışma sayfasında alt alta getirebilmek. Aşağıdaki kod kısmen işimi görüyor fakat hücre boşsa dikkate almıyor aktarma yapmıyor aslında ben ne görürse aynen getirsin istiyorum buna göre uyarlama yapılabilir mi yardımcı olursanız sevinirim.

Aşağıdaki linkdeki dosyaya bir bakınız

http://www.excel.web.tr/f117/kapaly-dosyalardan-veri-alma-t68879.html
Genişletmek için tıkla ...
 
Halit Hocam,

Çalışmalarınızı inceledim ellerinize sağlık çok güzel fakat benim makro bilgim yok 2 gündür kavramaya çalışsam da başaramadım. Elimden geldiğince aşağıdaki kodu uyarlamaya çalıştım. Şuan tek sıkıntım hücre boşsa getirmiyor dolayısıyla kayma oluyor. ikinci sıkıntım alt klasörleri dikkate almıyor, bana yardımcı olabilirsiniz çok sevinirim.

Kod: 
Sub VERİLERİ_GÜNCELLE()
    Application.ScreenUpdating = False
    Dosya_Yolu = "C:\Documents and Settings\Mustafa Çakıroğlu\Desktop\Tiryaki\Firmalar\Operasyonlar"
    Set S1 = Workbooks("Operasyon Takibi.xlsm").Sheets("Süreç")
    S1.Select
    [A5:H65536].ClearContents
    Range("J1").Select
    Selection.Copy
    Range("A2:H65536").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    For Each Dosya In Klasör
    If InStr(Dosya.Name, ".xlsm") > 0 Then
    If Dosya.Name <> "Operasyon Takibi.xlsm" Then
    Workbooks.Open Filename:=Dosya
    Sheets("İŞ AKIŞI").Select
    Range("A5:A" & [A65536].End(3).Row).Copy S1.Cells(65536, 1).End(3).Offset(1)
    Range("B5:B" & [B65536].End(3).Row).Copy S1.Cells(65536, 2).End(3).Offset(1)
    Range("C5:C" & [C65536].End(3).Row).Copy S1.Cells(65536, 3).End(3).Offset(1)
    Range("D5:D" & [D65536].End(3).Row).Copy S1.Cells(65536, 4).End(3).Offset(1)
    Range("E5:E" & [E65536].End(3).Row).Copy S1.Cells(65536, 5).End(3).Offset(1)
    Range("F5:F" & [F65536].End(3).Row).Copy S1.Cells(65536, 6).End(3).Offset(1)
        
    ActiveWorkbook.Close True
    End If
    End If
    Next
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Bir de aynı çalışma kitaplarının "abc" sayfalarının a2 , c6, d9 hücrelerini de aynı şekilde veri kitapçığında a,b,c kolonlarına aktarmak istiyorum bunu nasıl yapabilirim?

Teşekkürler,
 
Barfly' Alıntı:
Halit Hocam,

Çalışmalarınızı inceledim ellerinize sağlık çok güzel fakat benim makro bilgim yok 2 gündür kavramaya çalışsam da başaramadım. Elimden geldiğince aşağıdaki kodu uyarlamaya çalıştım. Şuan tek sıkıntım hücre boşsa getirmiyor dolayısıyla kayma oluyor. ikinci sıkıntım alt klasörleri dikkate almıyor, bana yardımcı olabilirsiniz çok sevinirim.

Örnek dosya ekleyin manuel olarakda olması gereken verileride renklendirin.
Genişletmek için tıkla ...
 
Halit Hocam,

Ekte 3 adet dosya mevcut, 2 tanesi veri içeren örnek dosya, diğeri ise verilerin geleceği veri dosyası. Örnek dosyaların dosya yolu şu şekilde;, (ilerleyen günlerde buraya sürekli dosya eklenecek);

1. dosya C:\.......\Operasyonlar\Barfly\Operasyon 01.xls
2. dosya C:\.......\Operasyonlar\Deneme\Operasyon 02.xls

Benim sizden istediğim yardım ise;

* Dosyaların tamamındaki İŞ EMRİ sayfalarından VERi dosyasında OPERASYON sayfasına tüm datalar ekte belirtildiği gibi alt alta gelebilsin

* Dosyaların tamamındaki İŞ AKIŞI sayfalarından VERi dosyasında iş akışları sayfasına tüm datalar ekte belirtildiği gibi alt alta gelebilsin. Dosyalardaki iş akışı sayfalarındaki tarih ve süreçlerin bir kısmı netleşmediği için boş kalabiliyor, boş gelen hücereler de aynen gelebilsin, yani boşsa orada bulunan veriyi de atlamadan getirebilsin.

Yardımcı olabilirseniz çok sevinirim.

Teşekkürler,
 

Ekli dosyalar

Dosyaların hepsi aynı yerde olmalı
operasyon sayfasınada kolon bazında diğer verileride ekledim.
 

Ekli dosyalar

Halit Hocam,

Yardımlarınız için çok teşekkür ederim, iş akışları aktarımı çok fazla yavaş çalışıyor 20 saniyede bir satır getirebiliyor, sıkıntı ne olabilir?

Teşekkürler,
 
Merhaba,

Alternatif olarak aşağıdaki kodu denermisiniz.

Kod: 
Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    
    Dosya_Yolu = ThisWorkbook.Path
    Set S1 = Workbooks("VERİ.xls").Sheets("İŞ AKIŞLARI")
    S1.Select
    Range("A2:F" & Rows.Count).ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    
    For Each Dosya In Klasör
        If InStr(Dosya.Name, ".xls") > 0 Then
            If Dosya.Name <> "VERİ.xls" Then
                Workbooks.Open Filename:=Dosya
                With Sheets("İŞ AKIŞI")
                    .Range("A2:F" & .Cells(65536, 1).End(3).Row).Copy S1.Cells(65536, 1).End(3).Offset(1)
                End With
                ActiveWorkbook.Close True
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Hocam,

İlginiz ve yardımınız için çok teşekkür ederim, kurguyu oturtmaya çalışıyorum, hata alırsam tekrar yardımcı olabilirseniz sevinirim.

Teşekkürler,
 
Affınıza sığınarak bir şey daha sormak istiyorum.

Yardımlarınızla Veri dosyasındaki "İş akışları" sayfası gayet hızlı bir şekilde veri aktarımı yapıyor. Operasyon sayfasında ise bir sıkıntım var.

Makro şuanda bütün dosyalardaki İŞ EMRİ sayfalarından verilen aralıklardaki tüm bilgiyi alıyor, peki İŞ EMRİ sayfası 1 değilde 5 adet olsa İŞ EMRİ 1, İŞ EMRİ 2, ... şeklinde. İŞ EMRİ 1 nolu sayfada C8 hücresi değeri 1 ise sadece İŞ EMRİ 1 sayfasının verisini alıp diğer dosyaya geçse 2 ise İŞ EMRİ 1 ve İŞ EMRİ 2 sayfalarından aynı şekilde verileri alsa ve VERİ dosyasında Operasyon sayfasına alt alta aktarsa 3,4, ve 5. İŞ EMRİ sayfalarını dikkate almasa. Böyle bir geliştirme yapmamız mümkün mü?

Örnek dosyalar eklidir.

Teşekkürler,
 

Ekli dosyalar

Merhaba,

"İŞ AKIŞLARI" isimli sayfanızdaki kodu aşağıdaki şekilde değiştirin.

Kod: 
Private Sub CommandButton1_Click()
    ONAY = MsgBox("Dosyalardan veri almak istiyor musunuz ?", vbYesNo)
    If ONAY = vbNo Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Dosya_Yolu = ThisWorkbook.Path
    Set S1 = Workbooks("VERİ.xls").Sheets("İŞ AKIŞLARI")
    S1.Select
    Range("A2:F" & Rows.Count).ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    
    For Each Dosya In Klasör
        If InStr(Dosya.Name, ".xls") > 0 Then
            If Dosya.Name <> "VERİ.xls" Then
                Workbooks.Open Filename:=Dosya
                With Sheets("İŞ AKIŞI")
                    .Range("A2:F" & .Cells(65536, 1).End(3).Row).Copy
                    S1.Cells(65536, 1).End(3).Offset(1).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                End With
                ActiveWorkbook.Close True
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub


"OPERASYON" isimli sayfanızdaki koduda aşağıdaki şekilde değiştirin.

Kod: 
Private Sub CommandButton1_Click()
    ONAY = MsgBox("Dosyalardan veri almak istiyor musunuz ?", vbYesNo)
    If ONAY = vbNo Then Exit Sub
    
    İLK = Application.InputBox("İŞ EMRİ başlangıç numarasını giriniz !", , 1)
    If İLK = "" Or İLK = False Then
        MsgBox "İşleminiz iptal edilmiştir !"
        Exit Sub
    End If
    
    SON = Application.InputBox("İŞ EMRİ bitiş numarasını giriniz !", , 5)
    If SON = "" Or SON = False Then
        MsgBox "İşleminiz iptal edilmiştir !"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Dosya_Yolu = ThisWorkbook.Path
    Set S1 = Workbooks("VERİ.xls").Sheets("OPERASYON")
    S1.Select
    Range("A2:AK" & Rows.Count).ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    
    For Each Dosya In Klasör
        If InStr(Dosya.Name, ".xls") > 0 Then
            If Dosya.Name <> "VERİ.xls" Then
                Workbooks.Open Filename:=Dosya
                For X = İLK To SON
                    Sayfa_Adı = "İŞ EMRİ (" & X & ")"
                    On Error Resume Next
                    If CBool(Len(Worksheets(Sayfa_Adı).Name) > 0) Then
                        With Sheets("İŞ EMRİ (" & X & ")")
                            Satır = S1.Cells(65536, 1).End(3).Row + 1
                            S1.Cells(Satır, 1).Value = .Range("F12").Value
                            
                            For Y = 2 To 21
                                S1.Cells(Satır, Y).Value = .Cells(Y + 36, "F").Value
                            Next
                            
                            For Y = 22 To 37
                                S1.Cells(Satır, Y).Value = .Cells(Y + 38, "F").Value
                            Next
                            
                            Application.CutCopyMode = False
                        End With
                    End If
                    On Error GoTo 0
                Next
                ActiveWorkbook.Close True
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub


Ayrıca ekteki uygulamalı dosyalarıda inceyebilirsiniz.


Not: Kodun sağlıklı çalışması için İŞ EMRİ sayfalarınızın isimleri eklediğiniz örnek dosyadaki gibi olmalıdır. Yani İŞ EMRİ (1) şeklinde olmalıdır. Aksi halde kodlar sağlıklı çalışmaz.
 

Ekli dosyalar

Barfly' Alıntı:
Affınıza sığınarak bir şey daha sormak istiyorum.

Yardımlarınızla Veri dosyasındaki "İş akışları" sayfası gayet hızlı bir şekilde veri aktarımı yapıyor. Operasyon sayfasında ise bir sıkıntım var.

Makro şuanda bütün dosyalardaki İŞ EMRİ sayfalarından verilen aralıklardaki tüm bilgiyi alıyor, peki İŞ EMRİ sayfası 1 değilde 5 adet olsa İŞ EMRİ 1, İŞ EMRİ 2, ... şeklinde. İŞ EMRİ 1 nolu sayfada C8 hücresi değeri 1 ise sadece İŞ EMRİ 1 sayfasının verisini alıp diğer dosyaya geçse 2 ise İŞ EMRİ 1 ve İŞ EMRİ 2 sayfalarından aynı şekilde verileri alsa ve VERİ dosyasında Operasyon sayfasına alt alta aktarsa 3,4, ve 5. İŞ EMRİ sayfalarını dikkate almasa. Böyle bir geliştirme yapmamız mümkün mü?

Örnek dosyalar eklidir.

Teşekkürler,
Genişletmek için tıkla ...

Dosyanızın içine bir adet data sayfası ekledim. Data sayfasındaki birinci satıra veri almak istediğiniz sayfa isimlerini yazın.OPERASYON sayfasındaki komut dığmesine basın.
 

Ekli dosyalar

Saygıdeğer hocalarım,

Emekleriniz için çok teşekkür ederim. İş akışları sayfası dört dörtlük çalışıyor fakat operasyon sayfasının aktarımı konusunda sanırım sıkıntıyı tam belirtemedim. Her operasyon dosyası kendi içinde X adet emri sayfası barındırabilir fakat her biri birbirinden bağımsız çalışıyor. Yani operasyon 01 dosyası 2 iş emri sayfasına sahipken operasyon 02 dosyası 5 iş emrine sahip olabilir. Bu sebeple her operasyon dosyasında C8 hücresine aktarımı yapılacak sayfa sayısını belirttim. Her dosyayı kendi içindeki C8 hücresinde bulunan sayıya göre dikkate alıp aktarsın diye, bu şekilde uygulamak mümkün müdür?

Teşekkürler,
 
Merhaba,

Operasyon dosyalarınızın ilk sayfasındaki C8 hücreleri sorgulanır. Aşağıdaki kodu denermisiniz.

Kod: 
Private Sub CommandButton1_Click()
    ONAY = MsgBox("Dosyalardan veri almak istiyor musunuz ?", vbYesNo)
    If ONAY = vbNo Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Dosya_Yolu = ThisWorkbook.Path
    Set S1 = Workbooks("VERİ.xls").Sheets("OPERASYON")
    S1.Select
    Range("A2:AK" & Rows.Count).ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    
    For Each Dosya In Klasör
        If InStr(Dosya.Name, ".xls") > 0 Then
            If Dosya.Name <> "VERİ.xls" Then
                Workbooks.Open Filename:=Dosya
                For X = 1 To Sheets(1).Range("C8")
                    Sayfa_Adı = "İŞ EMRİ (" & X & ")"
                    On Error Resume Next
                    If CBool(Len(Worksheets(Sayfa_Adı).Name) > 0) Then
                        With Sheets("İŞ EMRİ (" & X & ")")
                            Satır = S1.Cells(65536, 1).End(3).Row + 1
                            S1.Cells(Satır, 1).Value = .Range("F12").Value
                            
                            For Y = 2 To 21
                                S1.Cells(Satır, Y).Value = .Cells(Y + 36, "F").Value
                            Next
                            
                            For Y = 22 To 37
                                S1.Cells(Satır, Y).Value = .Cells(Y + 38, "F").Value
                            Next
                            
                            Application.CutCopyMode = False
                        End With
                    End If
                    On Error GoTo 0
                Next
                ActiveWorkbook.Close True
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan hocam,

Halit Hocamın çalışmasında klasörün içindeki alt klasörleri de sorgulayabiliyordu, sizin çalışmanıza bu özelliği eklemek mümkün mü?

Örneğin;


1. dosya C:\.......\Operasyonlar\Barfly\Operasyon 01.xls
2. dosya C:\.......\Operasyonlar\Deneme\Operasyon 02.xls

Bir de ben excel 2007 kullanıyorum koddaki tüm .xls ibarelerini makro içerdiği için .xlsm olarak revize ediyorum. Kodu çalıştırdığımda Veri.xlsm dosyasını da açıp veri almaya çalışıyor ve kod hata veriyor bunun sebebi ne olabilir?



Teşekkürler,
 
Son düzenleme:
Merhaba,

Aşağıdaki kodları uygulayıp denermisiniz. Bu kodlarla seçeceğiniz klasör altındaki tüm alt klasörleri sorgulayabilirsiniz.

Boş bir modüle;

Kod: 
Option Explicit
 
Function Sayfa_Kontrol(Sayfa As String) As Boolean
    On Error Resume Next
    Sayfa_Kontrol = CBool(Len(Worksheets(Sayfa).Name) > 0)
End Function


OPERASYON isimli sayfanızın kod bölümüne;

Kod: 
Dim Klasör As Object
Dim S1 As Worksheet
Dim Alt_Klasör As Object
Dim Alt_Dosya As Object
Dim Dosya As String
Dim Hedef_Dosya As Workbook
Dim Sayfa_Adı As String
Dim Say As Long
 
Private Sub CommandButton1_Click()
    ONAY = MsgBox("Dosyalardan veri almak istiyor musunuz ?", vbYesNo)
    If ONAY = vbNo Then Exit Sub
 
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işleminiz iptal edilmiştir !", vbExclamation
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Set S1 = ThisWorkbook.Sheets("OPERASYON")
    S1.Select
    Range("A2:AK" & Rows.Count).ClearContents
    Say = 0
 
    Liste (Klasör.Items.Item.Path)
    Alt_Liste (Klasör.Items.Item.Path)
    Set Klasör = Nothing
 
    Application.ScreenUpdating = True
 
    If Say = 0 Then
        MsgBox "Seçtiğiniz klasörde kriterlere uygun veri bulunamamıştır.", vbCritical
    Else
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    End If
End Sub
 
Private Sub Liste(Yol As String)
    Dosya = Dir(Yol & "\*.xls*")
 
    While Dosya <> ""
        DoEvents
 
        If InStr(Dosya, ".xls") > 0 Then
            If InStr(Dosya, "VERİ.xls") = 0 Then
                Set Hedef_Dosya = Workbooks.Open(Yol & "\" & Dosya, False, False)
                If InStr(Sheets(1).Name, "İŞ EMRİ") > 0 Then
                    For X = 1 To Sheets(1).Range("C8")
                        Sayfa_Adı = "İŞ EMRİ (" & X & ")"
                        If Sayfa_Kontrol(Sayfa_Adı) Then
                            With Sheets("İŞ EMRİ (" & X & ")")
                                Satır = S1.Cells(65536, 1).End(3).Row + 1
                                S1.Cells(Satır, 1).Value = .Range("F12").Value
 
                                For Y = 2 To 21
                                    S1.Cells(Satır, Y).Value = .Cells(Y + 36, "F").Value
                                Next
 
                                For Y = 22 To 37
                                    S1.Cells(Satır, Y).Value = .Cells(Y + 38, "F").Value
                                Next
 
                                Say = Say + 1
                                Application.CutCopyMode = False
                            End With
                        End If
                        On Error GoTo 0
                    Next
                    Hedef_Dosya.Close True
                Else
                    Hedef_Dosya.Close True
                End If
            End If
        End If
 
        Dosya = Dir
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Set Alt_Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasör
    Dosya = Dir(Alt_Dosya.Path & "\*.xls*")
        While Dosya <> ""
            DoEvents
 
            If InStr(Dosya, ".xls") > 0 Then
                If InStr(Dosya, "VERİ.xls") = 0 Then
                Set Hedef_Dosya = Workbooks.Open(Alt_Dosya.Path & "\" & Dosya, False, False)
                If InStr(Sheets(1).Name, "İŞ EMRİ") > 0 Then
                    For X = 1 To Sheets(1).Range("C8")
                        Sayfa_Adı = "İŞ EMRİ (" & X & ")"
                        If Sayfa_Kontrol(Sayfa_Adı) Then
                            With Sheets("İŞ EMRİ (" & X & ")")
                                Satır = S1.Cells(65536, 1).End(3).Row + 1
                                S1.Cells(Satır, 1).Value = .Range("F12").Value
 
                                For Y = 2 To 21
                                    S1.Cells(Satır, Y).Value = .Cells(Y + 36, "F").Value
                                Next
 
                                For Y = 22 To 37
                                    S1.Cells(Satır, Y).Value = .Cells(Y + 38, "F").Value
                                Next
 
                                Say = Say + 1
                                Application.CutCopyMode = False
                            End With
                        End If
                    Next
                    Hedef_Dosya.Close True
                Else
                    Hedef_Dosya.Close True
                End If
                End If
            End If
 
            Dosya = Dir
        Wend
    Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
    Set Alt_Klasör = Nothing
End Sub


İŞ AKIŞLARI isimli sayfanızın kod bölümüne;

Kod: 
Dim Klasör As Object
Dim S1 As Worksheet
Dim Alt_Klasör As Object
Dim Alt_Dosya As Object
Dim Dosya As String
Dim Hedef_Dosya As Workbook
Dim Say As Long
 
Private Sub CommandButton1_Click()
    ONAY = MsgBox("Dosyalardan veri almak istiyor musunuz ?", vbYesNo)
    If ONAY = vbNo Then Exit Sub
 
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işleminiz iptal edilmiştir !", vbExclamation
        Exit Sub
    End If
 
    Application.ScreenUpdating = False
 
    Set S1 = ThisWorkbook.Sheets("İŞ AKIŞLARI")
    S1.Select
    Range("A2:F" & Rows.Count).ClearContents
    Say = 0
 
    Liste (Klasör.Items.Item.Path)
    Alt_Liste (Klasör.Items.Item.Path)
    Set Klasör = Nothing
 
    Application.ScreenUpdating = True
 
    If Say = 0 Then
        MsgBox "Seçtiğiniz klasörde kriterlere uygun veri bulunamamıştır.", vbCritical
    Else
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    End If
End Sub
 
Private Sub Liste(Yol As String)
    Dosya = Dir(Yol & "\*.xls*")
 
    While Dosya <> ""
        DoEvents
 
        If InStr(Dosya, ".xls") > 0 Then
            If InStr(Dosya, "VERİ.xls") = 0 Then
                Set Hedef_Dosya = Workbooks.Open(Yol & "\" & Dosya, False, False)
                If Sayfa_Kontrol("İŞ AKIŞI") Then
                    With Sheets("İŞ AKIŞI")
                        .Range("A2:F" & .Cells(65536, 1).End(3).Row).Copy
                        S1.Cells(65536, 1).End(3).Offset(1).PasteSpecial Paste:=xlPasteValues
                        Say = Say + 1
                        Application.CutCopyMode = False
                    End With
                End If
                Hedef_Dosya.Close True
            End If
        End If
 
        Dosya = Dir
    Wend
End Sub
 
Private Sub Alt_Liste(Yol As String)
    Set Alt_Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Yol).SubFolders
 
    On Error GoTo Devam
 
    For Each Alt_Dosya In Alt_Klasör
    Dosya = Dir(Alt_Dosya.Path & "\*.xls*")
        While Dosya <> ""
            DoEvents
 
            If InStr(Dosya, ".xls") > 0 Then
                If InStr(Dosya, "VERİ.xls") = 0 Then
                    Set Hedef_Dosya = Workbooks.Open(Alt_Dosya.Path & "\" & Dosya, False, False)
                    If Sayfa_Kontrol("İŞ AKIŞI") Then
                        With Sheets("İŞ AKIŞI")
                            .Range("A2:F" & .Cells(65536, 1).End(3).Row).Copy
                            S1.Cells(65536, 1).End(3).Offset(1).PasteSpecial Paste:=xlPasteValues
                            Say = Say + 1
                            Application.CutCopyMode = False
                        End With
                    End If
                    Hedef_Dosya.Close True
                End If
            End If
 
            Dosya = Dir
        Wend
    Alt_Liste (Alt_Dosya.Path)
Devam:
    Next
    Set Alt_Klasör = Nothing
End Sub

Ekteki uygulamalı dosyayıda inceleyebilirsiniz.
 

Ekli dosyalar

Halit ve Korhan hocam;
Tüm sorulara sabırla cevap verdiğiniz için tüm üyeler adına size teşekkür ederim.Sizi takip ederek dahi yeterince bilgilenmek mümkün.
Biz sizden razıyız..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst