Hücre Aralığı "Range" Değiştirmek

[cenderus]

Değerli hocalarım;

aşağıdaki kodda sadece e ve g sutunları kopyalanıyor;
benim veri aralığım a29-fd65536 bu koda bu aralığı nasıl tanıtabilirim

Sub VERİLERİ_GÜNCELLE()
    Application.ScreenUpdating = False
    Dosya_Yolu = "C:\Documents and Settings\admin\Desktop\ANA DOSYA\1"
    Set S1 = Workbooks("ANA DOSYA.xls").Sheets("Sayfa1")
    S1.Select
    [A2:B65536].ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    For Each Dosya In Klasör
    If InStr(Dosya.Name, ".xls") > 0 Then
    If Dosya.Name <> "ANA DOSYA.xls" Then
    Workbooks.Open Filename:=Dosya
    Sheets("Sayfa1").Select
    Range("E2:E" & [E65536].End(3).Row).Copy S1.Cells(65536, 1).End(3).Offset(1)
    Range("G2:G" & [G65536].End(3).Row).Copy S1.Cells(65536, 2).End(3).Offset(1)
    ActiveWorkbook.Close True
    End If
    End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Veriler aktarılmıştır.", vbInformation
End Sub

yaptığım çalışma ana tabloda diğer veri dosyalarının konsolide edilmesi üzerine yani ana sayfada veri sayfalarıyla aynı adlarda sayflar var ve her sayfa o sayfayı içeren 4 veri dosyasından birinden veri alıyor, birden fazla sayfanın bu aralık için kopyalanması için bana bu kod önerilmişti,

Sub Book_Swap()
Dim sh As Worksheet
Dim sh2 As String
For Each sh In ActiveWorkbook.Sheets
    sh2 = sh.Name
    sh.Range("A29:FD4000").Value = Workbooks("dat1").Sheets(sh2).Range("A29:FD4000").Value
Next sh
End Sub

fakat bunun yerine yukardaki kodda tek tek sayfa adlarını girmeyi göze alıyorum gerçi 52 sayfa gireceğim bu kodu yavaşlatırmı bilmiyorum bu yüzden yardımınızı rica edeceğim,

 

[cenderus]

Sub VERİLERİ_GÜNCELLE()
    Application.ScreenUpdating = False
    Dosya_Yolu = "C:\Documents and Settings\admin\Desktop\ANA DOSYA\1"
    Set S1 = Workbooks("ANA DOSYA.xls").Sheets("Sayfa1")
    S1.Select
    [A2:FD65536].ClearContents
    Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    For Each Dosya In Klasör
    If InStr(Dosya.Name, ".xls") > 0 Then
    If Dosya.Name <> "ANA DOSYA.xls" Then
    Workbooks.Open Filename:=Dosya
    Sheets("Sayfa1").Select
    Range("A2:FD" & [FD65536].End(3).Row).Copy S1.Cells(65536, 1).End(3).Offset(1)
    ActiveWorkbook.Close True
    End If
    End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Veriler aktar&#305;lm&#305;&#351;t&#305;r.", vbInformation
End Sub

Kodu yukardaki gibi değitim ve oldu fakat birden fazla sayfada ne yapmalıyım sorusu var şimdi

 

[cenderus]

sanırım çözdüm ama uzun sürecek sanırım

hocalarım kodu bu şekilde ekleyerek birden fazla sayfa için uyarlayıyorum ama 52 sayfam var denediğimde 2 sayfada kopyalam işlemi uzun sürdü bu normalmi bunun kod olarak kolayı varmı acaba

Sub VERİLERİ_GÜNCELLE()
Application.ScreenUpdating = False
Dosya_Yolu = "C:\Documents and Settings\admin\Desktop\ANA DOSYA\1\"
Set S1 = Workbooks("ANA DOSYA.xls").Sheets("Sayfa1")
S1.Select
[A29:FD6000].ClearContents
Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
For Each Dosya In Klasör
If InStr(Dosya.Name, ".xls") > 0 Then
If Dosya.Name <> "ANA DOSYA.xls" Then
Workbooks.Open Filename:=Dosya
Sheets("Sayfa1").Select
Range("A29:FD6000" & [FD6000].End(3).Row).Copy S1.Cells(6000, 1).End(3).Offset(1)
ActiveWorkbook.Close True
End If
End If
Next
Set S1 = Workbooks("ANA DOSYA.xls").Sheets("Sayfa2")
S1.Select
[A29:FD6000].ClearContents
Set Klasör = CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
For Each Dosya In Klasör
If InStr(Dosya.Name, ".xls") > 0 Then
If Dosya.Name <> "ANA DOSYA.xls" Then
Workbooks.Open Filename:=Dosya
Sheets("Sayfa2").Select
Range("A29:FD6000" & [FD6000].End(3).Row).Copy S1.Cells(6000, 1).End(3).Offset(1)
ActiveWorkbook.Close True
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "Veriler aktarılmıştır.", vbInformation
End Sub