Arkadaşlar kusura bakmayın garip bir başlık oldu.Sorum şu aşağıdaki kod da gorulduğu üzere B2 - H8 ve I8 sutünlarındaki verileri çekıyor.Elimde çok fazla excel dosyası var ve hepsını makroya gore uyarlıyamam.Ama makroyu excellere gore uyarlıyablırım dıye dusunuyorum.Sorum şu aşağıdaki hangi kodu değiştirirsem örnek B9 - j13 den ve A41 sturundan veri almak istıyroum.
Yardımcı olursanız Çok sevinirim.Şimdiden teşekkurler.
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 "Veriler Çekildi"
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 & "]" & "İŞ YAPIŞ KURALLARI" & "'!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
Yardımcı olursanız Çok sevinirim.Şimdiden teşekkurler.
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 "Veriler Çekildi"
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 & "]" & "İŞ YAPIŞ KURALLARI" & "'!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
