arkadaşlar çok ugraştırm ama bi türlü yapamadım aşagıdaki kod bir klasördeki bütün excel dosyalarından Sayfa1 deki bütün verileri alıp kendi oluşturdugu dosyaya tek sayfa halinde kayıt ediyor
benim istediğim ise yine herşey aynı olacak ama veriyi alırken sayfanın tamamını değil a5 ile ap25 arasındaki tüm veriyi alacak
ayrıca klasördeki excel dosyalarının içindeki çalışma sayfasının adı sayfa1 olması gerekiyor bunu iptal edebilirmiyiz yani excel sayfası açıldıgında sadece aktif olan çalışma sayfasını alsın eğer bu olmazsa EK DERS ÇİZELGESİ yazan sayfayı alsın
şimdiden çok tşk ediyorum kod aşagıda
Option Explicit
Sub DOSYALARDAN_VERİ_AL()
Dim K1 As Workbook, K2 As Workbook
Dim K3 As Workbook, S1 As Worksheet
Dim X As Integer, Satır As Integer, Son_Satır As Long
Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)
If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
ElseIf Not Klasör Is Nothing Then
Kaynak_Klasör = Klasör.Items.Item.Path
Else
MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
"İşleminiz iptal edilmiştir.", vbCritical
Exit Sub
End If
On Error Resume Next
Set K1 = ThisWorkbook
Set K2 = Workbooks.Add(1)
Dosya = Dir(Kaynak_Klasör & "\*.xls")
Satır = 2
Application.ScreenUpdating = False
Do
If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
DoEvents
Application.DisplayAlerts = False
Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
Application.DisplayAlerts = True
Set S1 = K3.Sheets(1)
Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:AA" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""
K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
K2.Close True
Set K1 = Nothing
Set K2 = Nothing
Set K3 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
benim istediğim ise yine herşey aynı olacak ama veriyi alırken sayfanın tamamını değil a5 ile ap25 arasındaki tüm veriyi alacak
ayrıca klasördeki excel dosyalarının içindeki çalışma sayfasının adı sayfa1 olması gerekiyor bunu iptal edebilirmiyiz yani excel sayfası açıldıgında sadece aktif olan çalışma sayfasını alsın eğer bu olmazsa EK DERS ÇİZELGESİ yazan sayfayı alsın
şimdiden çok tşk ediyorum kod aşagıda
Option Explicit
Sub DOSYALARDAN_VERİ_AL()
Dim K1 As Workbook, K2 As Workbook
Dim K3 As Workbook, S1 As Worksheet
Dim X As Integer, Satır As Integer, Son_Satır As Long
Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)
If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
ElseIf Not Klasör Is Nothing Then
Kaynak_Klasör = Klasör.Items.Item.Path
Else
MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
"İşleminiz iptal edilmiştir.", vbCritical
Exit Sub
End If
On Error Resume Next
Set K1 = ThisWorkbook
Set K2 = Workbooks.Add(1)
Dosya = Dir(Kaynak_Klasör & "\*.xls")
Satır = 2
Application.ScreenUpdating = False
Do
If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
DoEvents
Application.DisplayAlerts = False
Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
Application.DisplayAlerts = True
Set S1 = K3.Sheets(1)
Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:AA" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""
K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
K2.Close True
Set K1 = Nothing
Set K2 = Nothing
Set K3 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub