Alt klasörleri dahil etme

S

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
23-02-2025
CK = ThisWorkbook.Name
Range("A2:b500").ClearContents
Cells(2, 1).Select

Application.ScreenUpdating = False
Cells(2, 1).Select
With Application.FileDialog(msoFileDialogFolderPicker)
On Error GoTo Bitir
.Show
MyFolder = .SelectedItems(1)
Bitir:
If MyFolder = "" Then Exit Sub
End With

MyFile = Dir(MyFolder & "\*.xlsm")
Do While MyFile <> ""


Workbooks.Open Filename:=MyFolder & "\" & MyFile
kit = ActiveWorkbook.Name
For syf = 1 To Sheets.Count
Sheets(syf).Select

yukarıda ki kod ile seçtiğim klasörde ki excel dosyalarından veri alıyorum. Seçilen dosyanın tüm alt klasörlerindeki excellerinden veri almam mümkün mü?
Yani klasör seçince alt klasörlerindeki excellere de ulaşsın. Teşekkürler.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kodun tamamını eklermisiniz.
 
S

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
23-02-2025
Kod: 
Private Sub CommandButton1_Click()
Application.AskToUpdateLinks = False
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
UserForm1.Hide
Application.DisplayAlerts = False
Dim MyFolder As String
Dim MyFile As String
MsgBox "İşleminiz tamamlanmıştır...' uyarısını görene kadar bekleyiniz... ", vbInformation



CK = ThisWorkbook.Name
Range("A2:b500").ClearContents
Cells(2, 1).Select

Application.ScreenUpdating = False
Cells(2, 1).Select
With Application.FileDialog(msoFileDialogFolderPicker)
    On Error GoTo Bitir
    .Show
    MyFolder = .SelectedItems(1)
Bitir:
If MyFolder = "" Then Exit Sub
End With


       

MyFile = Dir(MyFolder & "\*.xlsm")
Do While MyFile <> ""

    


    Workbooks.Open Filename:=MyFolder & "\" & MyFile
        kit = ActiveWorkbook.Name
    For syf = 1 To Sheets.Count
    Sheets(syf).Select

  
Cells(1, 2).Select
  If ActiveCell.Value <> "RİSK" Then GoTo indexsayfa
 
       '**** ---- ****



   
     Cells.Find(What:="İnceleme Sonucu", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
       
        'ActiveCell.Offset(1, 0).Select

 
KNADI = Range("A2").Value
RISK = Range("B2").Value
SONUC = Range("F2").Value

sutun = 0
SATIR = 0
AKSAKLIK = 0
DUZEN = 0
DUZELT = 0
UYGUNDEGİL = 0
IBRAZ = 0
MEVZ = 0
SUYGUNDEGİL = 0
DOSYAYOK = 0
isim = ActiveWorkbook.FullName




ActiveCell.Offset(1, 0).Select
Do While SATIR < 400
    If ActiveCell.Value = "ÖRNEK1" Then AKSAKLIK = A+ 1
    If ActiveCell.Value = "ÖRNEK2" Then DUZEN = D + 1
    If ActiveCell.Value = "ÖRNEK3" Then DUZELT = DU + 1
    If ActiveCell.Value = "ÖRNEK4" Then UYGUNDEGİL = UY + 1
    If ActiveCell.Value = "ÖRNEK5İ" Then IBRAZ = IB + 1
    If ActiveCell.Value = "ÖRNEK6" Then MEVZ = ME + 1
    If ActiveCell.Value = "ÖRNEK7 Then SUYGUNDEGİL = SUY + 1
    If ActiveCell.Value = "ÖRNEK8" Then DOSYAYOK = DOS + 1



    SATIR = SATIR + 1

    ActiveCell.Offset(1, 0).Select
Loop

Cells(5, 1).Select
Do While ActiveCell.Value <> ""
    sutun = sutun + 1
    ActiveCell.Offset(0, 1).Select
Loop


Application.DisplayAlerts = False
Workbooks(CK).Activate
Sheets("Kontrol").Select
ActiveCell.Value = KNADI
ActiveCell.Offset(0, 1).Value = A + D + DU + UY + IB + ME + SUY + DOS
ActiveCell.Offset(0, 2).Value = isim

ActiveCell.Offset(1, 0).Select
ornekadet = 0
   

      
       '**** ---- ****
      
'Application.ScreenUpdating = True
        
indexsayfa:
Workbooks(MyFile).Activate
    Next
Workbooks(kit).Close False




    MyFile = Dir
   
   
Loop
Application.ScreenUpdating = True

Range("a2:b330").Select
    ActiveWorkbook.Worksheets("Kontrol").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Kontrol").Sort.SortFields.Add Key:=Range("a2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Kontrol").Sort
        .SetRange Range("a2:b330")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With





MsgBox "İşleminiz tamamlanmıştır...", vbInformation

UserForm1.Show
Application.AskToUpdateLinks = True
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,299
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Foruma kod eklerken lütfen code tagını kullanınız. Ben mesajınızı düzenledim. Mesaj yazdığınız pencerede üç nokta olarak görünen menüden bu taga ulaşabilirsiniz.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kodları ekli resimdeki gibi ekle/kod alanına açılan pencereden yapıştırınız zira bu şekildeki kodlar metinlerle karışmaktadır.

Yeni Bit Eşlem Resmi.jpg
 
S

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
23-02-2025
Kod: 
Private Sub CommandButton1_Click()
Application.AskToUpdateLinks = False
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
UserForm1.Hide
Application.DisplayAlerts = False
Dim MyFolder As String
Dim MyFile As String
MsgBox "İşleminiz tamamlanmıştır...' uyarısını görene kadar bekleyiniz... ", vbInformation



CK = ThisWorkbook.Name
Range("A2:b500").ClearContents
Cells(2, 1).Select

Application.ScreenUpdating = False
Cells(2, 1).Select
With Application.FileDialog(msoFileDialogFolderPicker)
    On Error GoTo Bitir
    .Show
    MyFolder = .SelectedItems(1)
Bitir:
If MyFolder = "" Then Exit Sub
End With


      

MyFile = Dir(MyFolder & "\*.xlsm")
Do While MyFile <> ""

    


    Workbooks.Open Filename:=MyFolder & "\" & MyFile
        kit = ActiveWorkbook.Name
    For syf = 1 To Sheets.Count
    Sheets(syf).Select

 
Cells(1, 2).Select
  If ActiveCell.Value <> "RİSK" Then GoTo indexsayfa
 
       '**** ---- ****



  
     Cells.Find(What:="İnceleme Sonucu", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
      
        'ActiveCell.Offset(1, 0).Select

 
KNADI = Range("A2").Value
RISK = Range("B2").Value
SONUC = Range("F2").Value

sutun = 0
SATIR = 0
AKSAKLIK = 0
DUZEN = 0
DUZELT = 0
UYGUNDEGİL = 0
IBRAZ = 0
MEVZ = 0
SUYGUNDEGİL = 0
DOSYAYOK = 0
isim = ActiveWorkbook.FullName




ActiveCell.Offset(1, 0).Select
Do While SATIR < 400
    If ActiveCell.Value = "ÖRNEK1" Then AKSAKLIK = A+ 1
    If ActiveCell.Value = "ÖRNEK2" Then DUZEN = D + 1
    If ActiveCell.Value = "ÖRNEK3" Then DUZELT = DU + 1
    If ActiveCell.Value = "ÖRNEK4" Then UYGUNDEGİL = UY + 1
    If ActiveCell.Value = "ÖRNEK5İ" Then IBRAZ = IB + 1
    If ActiveCell.Value = "ÖRNEK6" Then MEVZ = ME + 1
    If ActiveCell.Value = "ÖRNEK7 Then SUYGUNDEGİL = SUY + 1
    If ActiveCell.Value = "ÖRNEK8" Then DOSYAYOK = DOS + 1



    SATIR = SATIR + 1

    ActiveCell.Offset(1, 0).Select
Loop

Cells(5, 1).Select
Do While ActiveCell.Value <> ""
    sutun = sutun + 1
    ActiveCell.Offset(0, 1).Select
Loop


Application.DisplayAlerts = False
Workbooks(CK).Activate
Sheets("Kontrol").Select
ActiveCell.Value = KNADI
ActiveCell.Offset(0, 1).Value = A + D + DU + UY + IB + ME + SUY + DOS
ActiveCell.Offset(0, 2).Value = isim

ActiveCell.Offset(1, 0).Select
ornekadet = 0
  

      
       '**** ---- ****
      
'Application.ScreenUpdating = True
        
indexsayfa:
Workbooks(MyFile).Activate
    Next
Workbooks(kit).Close False




    MyFile = Dir
  
  
Loop
Application.ScreenUpdating = True

Range("a2:b330").Select
    ActiveWorkbook.Worksheets("Kontrol").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Kontrol").Sort.SortFields.Add Key:=Range("a2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Kontrol").Sort
        .SetRange Range("a2:b330")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With





MsgBox "İşleminiz tamamlanmıştır...", vbInformation

UserForm1.Show
Application.AskToUpdateLinks = True
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Ben sizin kodlarınız çalıştıramadım sürekli hata veriyor.
onun için kendi yazdığım kodu ekliyorum siz kırmızı yerleri değiştirin

Rich (BB code): 
Private Sub CommandButton2_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Liste1 (Kaynak)

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste1(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files

j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Dosya
Cells(j, 2) = Dosya.Name

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste1 (f.Path)
sonraki:
Next

End Sub
 
S

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
23-02-2025
Sayın halit3 mevcut kodum biraz karışık. Vermiş olduğunuz kodu kendi koduma uyarlamam çok zor. Cevabınız için teşekkürler.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Çalışan kodunuzu ben çalıştıramadığım için yapamadım buraya eklediğiniz kod sizde çalışıyormu ?

bunu bir dene bu şekilde bir şey olması lazım

Kod: 
Private Sub CommandButton1_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Application.AskToUpdateLinks = False
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
UserForm1.Hide
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Range("A2:b500").ClearContents
Cells(2, 1).Select


Liste1 (Kaynak)

Range("a2:b330").Select
ActiveWorkbook.Worksheets("Kontrol").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Kontrol").Sort.SortFields.Add Key:=Range("a2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Kontrol").Sort
.SetRange Range("a2:b330")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


MsgBox "İşleminiz tamamlanmıştır...", vbInformation

UserForm1.Show
Application.AskToUpdateLinks = True
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources



Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste1(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

CK = ThisWorkbook.Name

For Each Dosya In fL.GetFolder(yol).Files

Workbooks.Open Filename:=Dosya
kit = ActiveWorkbook.Name
For syf = 1 To Sheets.Count
Sheets(syf).Select


Cells(1, 2).Select
If ActiveCell.Value <> "RİSK" Then GoTo indexsayfa

'**** ---- ****

Cells.Find(What:="İnceleme Sonucu", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate

'ActiveCell.Offset(1, 0).Select


KNADI = Range("A2").Value
RISK = Range("B2").Value
SONUC = Range("F2").Value

sutun = 0
SATIR = 0
AKSAKLIK = 0
DUZEN = 0
DUZELT = 0
UYGUNDEGİL = 0
IBRAZ = 0
MEVZ = 0
SUYGUNDEGİL = 0
DOSYAYOK = 0
isim = ActiveWorkbook.FullName




ActiveCell.Offset(1, 0).Select
Do While SATIR < 400
If ActiveCell.Value = "ÖRNEK1" Then AKSAKLIK = A + 1
If ActiveCell.Value = "ÖRNEK2" Then DUZEN = D + 1
If ActiveCell.Value = "ÖRNEK3" Then DUZELT = DU + 1
If ActiveCell.Value = "ÖRNEK4" Then UYGUNDEGİL = UY + 1
If ActiveCell.Value = "ÖRNEK5İ" Then IBRAZ = IB + 1
If ActiveCell.Value = "ÖRNEK6" Then MEVZ = Me + 1
If ActiveCell.Value = "ÖRNEK7" Then SUYGUNDEGİL = SUY + 1
If ActiveCell.Value = "ÖRNEK8" Then DOSYAYOK = DOS + 1



SATIR = SATIR + 1

ActiveCell.Offset(1, 0).Select
Loop

Cells(5, 1).Select
Do While ActiveCell.Value <> ""
sutun = sutun + 1
ActiveCell.Offset(0, 1).Select
Loop


Application.DisplayAlerts = False
Workbooks(CK).Activate
Sheets("Kontrol").Select
ActiveCell.Value = KNADI
ActiveCell.Offset(0, 1).Value = A + D + DU + UY + IB + Me + SUY + DOS
ActiveCell.Offset(0, 2).Value = isim

ActiveCell.Offset(1, 0).Select
ornekadet = 0


indexsayfa:
Workbooks(Dosya).Activate

Next


Workbooks(kit).Close False
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste1 (f.Path)
sonraki:
Next

End Sub
 
S

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
23-02-2025
Sayın@ halit3 çalışan bir örnek haızrladım. Veri say dosyasında Ana Klasör içindeki 1 isimli klasörü seçince içindeki excellerde sayım yapıyor. Aynı şekilde Ana Klasör içindeki 2 isimli klasörü seçince içindeki excellerde sayım yapıyor. Fakat ben Ana Klasörü seçip 1 ve 2 isimli dosyalardaki excellerin içindeki verileri almak istiyorum.
 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
yazdığın bilgiler yetersiz geldi bana ben anlayamadım kodun ne yaptığını

bu kodu bir dene
kodu çalıştırdığınızda veri alınacak klasörü seçmeniz yeterli

Kod: 
Dim Sayfa_adi
Dim Dosya_adi

Sub verikayityap()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_adi = ActiveSheet.Name
Dosya_adi = ThisWorkbook.Name

Range("A2:B500").ClearContents

Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

For Each Dosya In fL.GetFolder(yol).Files

If ThisWorkbook.Name <> Dosya.Name Then
Set wb = Workbooks.Open(Dosya)
Sayf = ActiveSheet.Name


son = ActiveWorkbook.Worksheets(Sayf).Cells(Rows.Count, "a").End(3).Row - 5
i = WorksheetFunction.CountA(ThisWorkbook.Worksheets(Sayfa_adi).Range("A1:A" & Rows.Count)) + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "A").Value = ActiveWorkbook.Worksheets(Sayf).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "b").Value = son
wb.Close
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub
 
S

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
23-02-2025
Hocam sizin yazdığınız kod ile bendeki aynı sonucu veriyor tabi ki sizinki çok hızlı çalışıyor. fakat şöyle bir hata aldım. hata.GIF
 
halit3

halit3

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

Kod: 
Dim Sayfa_adi
Dim Dosya_adi

Sub verikayityap()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_adi = ActiveSheet.Name
Dosya_adi = ThisWorkbook.Name

Range("A2:B500").ClearContents

Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

For Each Dosya In fL.GetFolder(yol).Files

If fL.GetFileName(Dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(Dosya), 1, 2) = "~$" Then
GoSub atla1
End If

Set wb = Workbooks.Open(Dosya)
Sayf = ActiveSheet.Name


son = ActiveWorkbook.Worksheets(Sayf).Cells(Rows.Count, "a").End(3).Row - 5
i = WorksheetFunction.CountA(ThisWorkbook.Worksheets(Sayfa_adi).Range("A1:A" & Rows.Count)) + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "A").Value = ActiveWorkbook.Worksheets(Sayf).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "b").Value = son
wb.Close
atla1:
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub
 
S

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
23-02-2025
Hocam çok oldum biliyorum ama son bir sorum daha var. Excel dosyalarının sadece ilk sayflarından veri alıyor bütün sayfalarından veri alcak hale getirebilirmiyiz kodu.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
İyi de örnek dosyalarınızda bir sayfa var
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kodları yeniden güncelledim.

Kod: 
Dim Sayfa_adi


Sub verikayityap()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_adi = ActiveSheet.Name
Range("A2:B500").ClearContents

Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

For Each Dosya In fL.GetFolder(yol).Files

If fL.GetFileName(Dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(Dosya), 1, 2) = "~$" Then
GoSub atla1
End If

Set wb = Workbooks.Open(Dosya)

yenidosya_adı = ActiveWorkbook.Name

For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
Sayf = Workbooks(yenidosya_adı).Sheets(r).Name
son = Workbooks(yenidosya_adı).Sheets(r).Cells(Rows.Count, "a").End(3).Row - 5
i = WorksheetFunction.CountA(ThisWorkbook.Worksheets(Sayfa_adi).Range("A1:A" & Rows.Count)) + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "A").Value = Workbooks(yenidosya_adı).Sheets(r).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "b").Value = son
Next r

wb.Close
atla1:
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,800
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Küçük düzeltme yapıldı

Kod: 
Dim Sayfa_adi


Sub verikayityap()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sayfa_adi = ActiveSheet.Name
Range("A2:B500").ClearContents

Liste (Kaynak)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

Dim wb As Workbook

For Each Dosya In fL.GetFolder(yol).Files

If fL.GetFileName(Dosya) = ThisWorkbook.Name Or Mid(fL.GetFileName(Dosya), 1, 2) = "~$" Then
GoSub atla1
End If

Set wb = Workbooks.Open(Dosya)

yenidosya_adı = ActiveWorkbook.Name

For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
Sayf = Workbooks(yenidosya_adı).Sheets(r).Name
If Sayf <> "açıklama" Then

son = WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(r).Range("A6:A" & Rows.Count))

i = WorksheetFunction.CountA(ThisWorkbook.Worksheets(Sayfa_adi).Range("A1:A" & Rows.Count)) + 1
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "A").Value = Workbooks(yenidosya_adı).Sheets(r).Cells(2, "a").Value
ThisWorkbook.Worksheets(Sayfa_adi).Cells(i, "b").Value = son
End If
Next r

wb.Close
atla1:
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub
 
Son düzenleme:
S

schlecht

Altın Üye
Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
Altın Üyelik Bitiş Tarihi
23-02-2025
Hocam İlk açılan excelin ilk sayfasını klasördeki excel sayısı kadar sayıyor. Karşısınada toplam excel sayfalarını yazıyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst