Klasörün içindeki excel dosyası

[adsoft]

slm üstadlar ekte sunmuş olduğum klasörde 4 adet excell dosyası var bunların içinde anasayfa olan excell dosyasına diğer excell sayfalarındaki "E3" hücresindeki rakamları ve "a1" hücresindeki açılamayı atmasını istiyorum. bunu nasıl yapabilirim
ayrıca bu klasörün içindeki dosyalar şimdilik üç tane ("anasayfa dosyası hariç") ilerde işin durumuna göre çoğalabilir

 

[asi_kral]

slm üstadlar ekte sunmuş olduğum klasörde 4 adet excell dosyası var bunların içinde anasayfa olan excell dosyasına diğer excell sayfalarındaki "E3" hücresindeki rakamları ve "a1" hücresindeki açılamayı atmasını istiyorum. bunu nasıl yapabilirim
ayrıca bu klasörün içindeki dosyalar şimdilik üç tane ("anasayfa dosyası hariç") ilerde işin durumuna göre çoğalabilir

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub Dosyadan_Bilgi_Çel_1967()
'Konu       :   Klasördeki Dosyalardan Bilgi Çekme
'Mail       :   m.batu.1967@gmail.com
'Coder By   :   asi_kral_1967
Dim asi, kral,a
Application.ScreenUpdating = False
asi = ThisWorkbook.Path & "\"
kral = Dir(asi & "*.xlsx?")
Range("A2:C" & Rows.Count).ClearContents
a = 2
Do While kral <> ""
Cells(a, "A").Value = a - 1
Cells(a, "B").Value = Application.ExecuteExcel4Macro("'" & asi & "[" & kral & "]HESAP'!R1C1")
Cells(a, "C").Value = Application.ExecuteExcel4Macro("'" & asi & "[" & kral & "]HESAP'!R3C5")
a = a + 1
kral = Dir
Loop
Application.ScreenUpdating = True
End Sub

Eki inceleyiniz

 

[Ömer]

Merhaba,

Alternatif olsun.

Sub VeriGetir()
 
    Dim yol As Object, sat As Long, ad As String
    Dim dosya, d, uzantı As String, adr As String

 
    Set yol = CreateObject("Scripting.FileSystemObject"). _
                GetFolder([COLOR=blue]ThisWorkbook.Path[/COLOR]).Files
 
    Application.ScreenUpdating = False
    adr = [COLOR=blue]ThisWorkbook.Path[/COLOR] & "\"
 
    Range("A2:C" & Rows.Count).ClearContents
 
    sat = 2
    For Each dosya In yol
        d = Split(dosya.Name, ".")
        uzantı = "." & d(UBound(d))
        ad = Replace(dosya.Name, uzantı, "")
        If ad <> "ANASAYFA" Then
            Cells(sat, "A") = sat - 1
            Cells(sat, "B") = ExecuteExcel4Macro("'" & adr & _
                            "[" & dosya.Name & "]" & "HESAP'!R1C1")
            Cells(sat, "C") = ExecuteExcel4Macro("'" & adr & _
                            "[" & dosya.Name & "]" & "HESAP'!R3C5")
            sat = sat + 1
        End If
    Next dosya
 
End Sub

.

 

[adsoft]

çok tşk ederim

 

[asi_kral]

çok tşk ederim

Kolay Gelsin.