Değerli Hocalarım herkese hayırlı akşamlar. Bir makroda daha yardımınıza ihtiyacım var. Aşağıya kodlarını eklediğim(ben birazcık değiştirdim) sağolsun daha önce Tarkan Vural hocamın hazırladığı Ali öz hocamın yardım ettiği kapalı dosyadan veri alan makroyu başka bir şekle uyarlamak istiyorum, tabi istediğim gibi olabilirmi bilmiyorum. Aşağıdaki makro hadımköy klosörüne gidip kaçtane çalışma kitabı varsa içinde kaçtane sayfa varsa belirtilen verileri benim ana sosyam olan musteri takip çalışmamın hadımköy sayfasına getiriyor. Benim istediğimse veri aldığı sayfanın aynısından benim müsteri takip çalışmamda aynı isimde bir sayfa oluşturup verileri sayfalara kaydetmesi. yani bir sayfaya getirmesinde açtığı sayfalarda ne kadar veri varsa aynı sayfanın isminden benim müsteri takip dosyamda oluşturup buraya yüklesin. Mümkün olursa çok makbule geçer. Şimdiden teşekkür ederim.
Sub YuceldenVeriGetir()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date
Dim evn As Object, klasoradi As String, kitap As Workbook
Dim i As Integer, x As Integer, dosyam As Workbook
Set kitap = ThisWorkbook
kitap.Sheets("HADIMKÖY").Range("a2:W65536").ClearContents
klasoradi = "HADIMKÖY"
Set evn = CreateObject("scripting.filesystemobject")
Set dosyalar = evn.getfolder(ThisWorkbook.Path & Application.PathSeparator & klasoradi)
For Each klasor In dosyalar.Files
Set dosyam = GetObject(klasor.Path)
For i = 1 To dosyam.Sheets.Count
For x = 1 To 50
dosyam.Sheets(i).Range("a" & x & ":w" & x).Copy
kitap.Sheets("HADIMKÖY").Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
Next x
Next i
dosyam.Close False
Next klasor
MsgBox "Raporlama tamamlandı. ", vbInformation, "Www.ExcelVBA.Net"
Set evn = Nothing: Set kitap = Nothing: Set dosyam = Nothing
Application.ScreenUpdating = True
End Sub
Sub YuceldenVeriGetir()
Application.ScreenUpdating = False
Dim tarih1 As Date, tarih2 As Date, xtarih As Date
Dim evn As Object, klasoradi As String, kitap As Workbook
Dim i As Integer, x As Integer, dosyam As Workbook
Set kitap = ThisWorkbook
kitap.Sheets("HADIMKÖY").Range("a2:W65536").ClearContents
klasoradi = "HADIMKÖY"
Set evn = CreateObject("scripting.filesystemobject")
Set dosyalar = evn.getfolder(ThisWorkbook.Path & Application.PathSeparator & klasoradi)
For Each klasor In dosyalar.Files
Set dosyam = GetObject(klasor.Path)
For i = 1 To dosyam.Sheets.Count
For x = 1 To 50
dosyam.Sheets(i).Range("a" & x & ":w" & x).Copy
kitap.Sheets("HADIMKÖY").Range("a65536").End(3)(2, 1).PasteSpecial xlPasteValues
Next x
Next i
dosyam.Close False
Next klasor
MsgBox "Raporlama tamamlandı. ", vbInformation, "Www.ExcelVBA.Net"
Set evn = Nothing: Set kitap = Nothing: Set dosyam = Nothing
Application.ScreenUpdating = True
End Sub