Klasördeki dosyaların belirli hücrelerinde ki verileri listeleme.

[simetri.]

Merhabalar,

Klasörler ve alt klasörlerde ki excel dosyalarının tüm sayfalarının belirli hücrelerini

Çalışma kitabına listelemek için bir kod istemekteyim.

Kod excel dosyalarının A3 , H7 ve K5 hücrelerinde ki verileri.

Çalışma kitabında (5. satır itibari ile)aynı satıra listeleyecek.

Detaylar örnek dosyada mevcut.

Eğer ki A sütununa da ilgili sayfa ismini yazarsa şahane olur.

Değerli yardımlarınızı bekliyorum.


NOT : Aşağıdaki kod değerli üstad sayın Halit3 hocamıza ait.

İlgili kod da belirli hücreleri listeliyor. Lakin sadece tek bir sayfanın

verilerini listeliyor. Bu koda da revizyon yapılabilir. Buradan kendisine

tekrar teşekkür ederim.

Sub aktar()
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
sat1 = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Liste (ThisWorkbook.Path)
MsgBox "İŞLEM TAMAM"
End Sub
Private Sub Liste(Kalasor As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Kalasor).subfolders
Dim wb As Workbook
Dosya = Dir(Kalasor & "\*.xls")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
deg = "'" & Kalasor & "\" & "[" & Dosya & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1
Cells(sat, 1) = ExecuteExcel4Macro(deg & 2 & "C2")
Cells(sat, 2) = ExecuteExcel4Macro(deg & 8 & "C8")
Cells(sat, 3) = ExecuteExcel4Macro(deg & 8 & "C9")

End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub

 

[halit3]

Merhabalar,

Klasörler ve alt klasörlerde ki excel dosyalarının tüm sayfalarının belirli hücrelerini

Çalışma kitabına listelemek için bir kod istemekteyim.

Kod excel dosyalarının A3 , H7 ve K5 hücrelerinde ki verileri.

Çalışma kitabında (5. satır itibari ile)aynı satıra listeleyecek.

Detaylar örnek dosyada mevcut.

Eğer ki A sütununa da ilgili sayfa ismini yazarsa şahane olur.

Değerli yardımlarınızı bekliyorum.


NOT : Aşağıdaki kod değerli üstad sayın Halit3 hocamıza ait.

İlgili kod da belirli hücreleri listeliyor. Lakin sadece tek bir sayfanın

verilerini listeliyor. Bu koda da revizyon yapılabilir. Buradan kendisine

tekrar teşekkür ederim.

Sub aktar()
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
sat1 = 2
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Liste (ThisWorkbook.Path)
MsgBox "İŞLEM TAMAM"
End Sub
Private Sub Liste(Kalasor As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Kalasor).subfolders
Dim wb As Workbook
Dosya = Dir(Kalasor & "\*.xls")
'Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False
deg = "'" & Kalasor & "\" & "[" & Dosya & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1
Cells(sat, 1) = ExecuteExcel4Macro(deg & 2 & "C2")
Cells(sat, 2) = ExecuteExcel4Macro(deg & 8 & "C8")
Cells(sat, 3) = ExecuteExcel4Macro(deg & 8 & "C9")

End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kalasor = f.Path
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
Application.ScreenUpdating = True
End Sub

kod:

Sub aktar()
a = MsgBox("DOSYALARINDAN VERİ ALMAK İSTİYORMUSUNUZ.?", vbYesNo)
If a = vbNo Then
Exit Sub
End If
Range(Cells(5, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Application.ScreenUpdating = False
Liste9 (ThisWorkbook.Path)
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAM"
End Sub

Private Sub Liste9(yol As String)
Dim fs As Object, f As Object, j As Long

Set fs = CreateObject("Scripting.FileSystemObject")
ReDim sayfaadi(50)

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

uzanti = fs.GetExtensionName(Dosya)

If uzanti = "xls" Or uzanti = "xlsx" Or uzanti = "xlsm" Or uzanti = "xlsb" Then

If ThisWorkbook.Name <> Dosya.Name Then
'On Error Resume Next

For k = 1 To 50
sayfaadi(k) = ""
Next
sat1 = 0
'MsgBox Workbooks(Dosya).Application.Name

Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
dosya_adı = Dosya
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then
sat1 = sat1 + 1
sayfaadi(sat1) = Left$(son1, Len(son1) - 1)

End If
End If
End If
End If
End If
Next
Set Data = Nothing
Set Katalog = Nothing

Application.DisplayAlerts = False

For i = 1 To sat1
deg = "'" & yol & "\" & "[" & Dosya.Name & "]" & sayfaadi(i) & "'!R"

sat = WorksheetFunction.CountA(Range("A1:a65000")) + 5
Cells(sat, 2) = ExecuteExcel4Macro(deg & 3 & "C1")
Cells(sat, 4) = ExecuteExcel4Macro(deg & 7 & "C8")
Cells(sat, 5) = ExecuteExcel4Macro(deg & 5 & "C11")
Cells(sat, 1) = Dosya.Name & " " & sayfaadi(i)
Next

End If

End If
Next

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

Set fL = Nothing
End Sub

 

[simetri.]

Harika olmuş vallahi.

Çok teşekkür ederim Halit Hocam.

Ellerinize sağlık.