Çözüldü Makro düzenleme

[cem12]

Merhaba Arkadaşlar

Aşağıdaki makroda filename dosyasının içerisindeki, her sayfada range Y15:AD41 i başka bir çalışma kitabının içine kopyalamam lazım.Ama excel bu işlemi tek bir sayfa için yapıp kalan sayfalara işlem yapmadan makroyu sonlandırıyor.Yanlış olabileceği yeri işaretledim.Yardım edebilir misiniz ?

Not :For each worksheet in workbook(filename) olarak denediğimde de aynı şekilde tek sayfaya işlem yapıp kalan sayfalara işlem yapmadan makroyu sonlandırıyor

Yanlış olabileceğini düşündüğüm yeri işaretledim.Yardım edebilir misiniz ?


Sub b()
Dim directory As String, fileName As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

directory = "C:\Users\CEM\Desktop\Özel Office Şablonları 1" & "\"

For i = 1 To Sayfa1.Range("A100000").End(xlUp).Row
fileName = Cells(i, 1)
If fileName <> "" Then
Sayfa1.Range("B" & Sayfa1.Cells(i, "A").Row & "" & Sayfa1.Cells(i, "A").Row).Copy
Sayfa4.Range("B5").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Workbooks.Open (directory & fileName)
For kl = 1 To Workbooks(fileName).Sheets.Count
Range("Y15:AD41").Select
Selection.Copy
Windows("deneme.xlsm").Activate
Sheets("TUMU").Select
ABC = [a65536].End(3).Row + 1
Range("a" & ABC).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
kl = kl + 1
Windows(fileName).Activate



Next kl

Workbooks(fileName).Close SaveChanges:=False
On Error Resume Next
End If

Sheets("GENEL").Select

Next i
End Sub

 

[turist]

Aşağıdaki gibi deneyin.

Sub b()
Dim directory As String, fileName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "C:\Users\CEM\Desktop\Özel Office Şablonları 1" & "\"
For i = 1 To Sayfa1.Range("A100000").End(xlUp).Row
fileName = Cells(i, 1)
If fileName <> "" Then
Sayfa1.Range("B" & Sayfa1.Cells(i, "A").Row & ":D" & Sayfa1.Cells(i, "A").Row).Copy
Sayfa4.Range("B5").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Workbooks.Open (directory & fileName)
For kl = 1 To Workbooks(fileName).Sheets.Count
Range("Y15:AD41").Select
Selection.Copy
Windows("deneme.xlsm").Activate
Sheets("TUMU").Select
ABC = [a65536].End(3).Row + 1
Range("a" & ABC).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows(fileName).Activate
Workbooks(fileName).Close SaveChanges:=False
On Error Resume Next
Next kl
End If
Next i
Sheets("GENEL").Select
End Sub

 

[cem12]

Merhaba
For kl = 1 To Workbooks(fileName).Sheets.Count burada hata veriyor

 

[halit3]

Bu bölüm belki işinize yarar

Workbooks.Open (directory & fileName)
dosya = ActiveWorkbook.Name
ThisWorkbook.Worksheets(ActiveSheet.Name).Range("A1:CN" & Rows.Count).ClearContents
sayfa = ActiveSheet.Name
For kl = 1 To Workbooks(dosya).Sheets.Count
ActiveWorkbook.Worksheets(ActiveSheet.Name).Range("Y15:AD41").Copy
ABC = [a65536].End(3).Row + 1
ThisWorkbook.Sheets("TUMU").Paste Destination:=ThisWorkbook.Sheets("TUMU").Range("a" & ABC)
Workbooks(dosya).Close SaveChanges:=False
Next kl

 

[cem12]

Merhaba bu ikisinin yerini değiştirerek makroyu çalıştırabildim.Ama aynı şekilde dosyayı açtığı zaman hangi sayfa aktifse sadece ona işlem yapıyor.Diğer sayfalara yapmıyor.

Workbooks(dosya).Close SaveChanges:=False
Next kl

 

[halit3]

Merhaba alıntı yaparak cevap yazarmısınız
Örnek dosyaları ekleyin bir görelim

 

[cem12]

Merhaba alıntı yaparak cevap yazarmısınız
Örnek dosyaları ekleyin bir görelim

Merhaba

İlki makronun olduğu diğeri, bilgi almam gereken dosya

https://drive.google.com/open?id=1lwjkiR5j1t-xpLcZDG_OmwlZe-_QkZnW
https://drive.google.com/open?id=1fTdJwqQ1kR5oXtC85MuVxjY0Ro6i-jm9

 

[halit3]

kod:

Sub b()
Dim directory As String, fileName As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

directory = "C:\Users\Viola\Desktop\Cem\Özel Office Şablonları 2" & "\"
For i = 2 To ThisWorkbook.Sheets("GENEL").Cells(Rows.Count, "A").End(3).Row

dosya = directory & ThisWorkbook.Sheets("GENEL").Cells(i, 1)
If dosya <> "" Then
son = ThisWorkbook.Sheets("GENEL").Cells(Rows.Count, "b").End(3).Row
ThisWorkbook.Sheets("GENEL").Range(ThisWorkbook.Sheets("GENEL").Cells(2, 2), ThisWorkbook.Sheets("GENEL").Cells(son, "d")).Copy
ThisWorkbook.Sheets("Ana Sayfa").Paste Destination:=ThisWorkbook.Sheets("Ana Sayfa").Range("B5")
Workbooks.Open (dosya)

dosya2 = ActiveWorkbook.Name
sayfa = ActiveSheet.Name
For kl = 1 To Workbooks(dosya2).Sheets.Count
ActiveWorkbook.Worksheets(Sheets(kl).Name).Range("Y15:AD41").Copy
ABC = ThisWorkbook.Sheets("TUMU").Cells(Rows.Count, "a").End(3).Row + 1
ThisWorkbook.Sheets("TUMU").Paste Destination:=ThisWorkbook.Sheets("TUMU").Range("a" & ABC)
Next kl
Workbooks(dosya2).Close SaveChanges:=False
End If

Next i
End Sub

 

[cem12]

kod:

Sub b()
Dim directory As String, fileName As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "C:\Users\Viola\Desktop\Cem\Özel Office Şablonları 2" & "\"
For i = 2 To ThisWorkbook.Sheets("GENEL").Cells(Rows.Count, "A").End(3).Row

dosya = directory & ThisWorkbook.Sheets("GENEL").Cells(i, 1)
If dosya <> "" Then
son = ThisWorkbook.Sheets("GENEL").Cells(Rows.Count, "b").End(3).Row
ThisWorkbook.Sheets("GENEL").Range(ThisWorkbook.Sheets("GENEL").Cells(2, 2), ThisWorkbook.Sheets("GENEL").Cells(son, "d")).Copy
ThisWorkbook.Sheets("Ana_Sayfa").Paste Destination:=ThisWorkbook.Sheets("Ana_Sayfa").Range("B5")
Workbooks.Open (dosya)

dosya2 = ActiveWorkbook.Name
sayfa = ActiveSheet.Name
For kl = 1 To Workbooks(dosya2).Sheets.Count
ActiveWorkbook.Worksheets(Sheets(kl).Name).Range("Y15:AD41").Copy
ABC = ThisWorkbook.Sheets("TUMU").Cells(Rows.Count, "a").End(3).Row + 1
ThisWorkbook.Sheets("TUMU").Paste Destination:=ThisWorkbook.Sheets("TUMU").Range("a" & ABC)
Next kl
Workbooks(dosya2).Close SaveChanges:=False
End If

Next i
End Sub

ThisWorkbook.Sheets("Ana_Sayfa").Paste Destination:=ThisWorkbook.Sheets("Ana_Sayfa").Range("B5")

burada hata gösteriyor

 

[halit3]

Söylemeyi unutmuşum
dosyanızdaki sayfa adı (Ana Sayfa) bu ben sayfa adını (Ana_Sayfa) bunu yapmıştım.
eğer dosyanızdaki sayfa adını kırmızı yerdeki gibi değiştirirseniz kod çalışacaktır.

 

[cem12]

Söylemeyi unutmuşum
dosyanızdaki sayfa adı (Ana Sayfa) bu ben sayfa adını (Ana_Sayfa) bunu yapmıştım.
eğer dosyanızdaki sayfa adını kırmızı yerdeki gibi değiştirirseniz kod çalışacaktır.

Doğru söylüyorsunuz.Bende atlamışım bunu.

Emeğinize sağlık sorunsuz çalışıyor.Yardımlarınız için çok teşekkür ederim

 

[halit3]

Doğru söylüyorsunuz.Bende atlamışım bunu.

Emeğinize sağlık sorunsuz çalışıyor.Yardımlarınız için çok teşekkür ederim

Teşekkürler iyi çalışmalar