Makro Tek butonla her sayfa için aynı işlemi yapsın

[Barfly]

Aşağıdaki kod TRD-BER sayfasında çalışıyor fakat ben 50 farklı sayfada bu kodu ayrı ayrı çalıştırmak istiyorum. Örneğin TRD adlı bir sheetde A1-A50 arası sayfa isimlerini sıralasam ve aşağıdaki koda bunu döngü olarak tanımlasam her seferinde ilgili sheet adı değişse ve o sayfa için makro çalışsa. Böyle bir şeyi aşağıdaki koda nasıl entegre edebilirim ve ana sayfada ki buton ile çalışır mı yardımcı olabilirseniz sevinirim.

Sub TRD_BER()
Dim sh As Worksheet, sat1 As Long, sat2 As Long
Dim k As Range, adr As String
Sheets("TRD-BER").Select
Application.ScreenUpdating = False
Range("A3:W" & Rows.Count).ClearContents
Range("AC3:AC" & Rows.Count).ClearContents
Set sh = Sheets("TEMIZ")
sat2 = sh.Cells(Rows.Count, "V").End(xlUp).Row
Set k = sh.Range("V2:V" & sat2).Find(Range("CC2").Value, , xlValues, xlWhole)
sat1 = 3
If Not k Is Nothing Then
adr = k.Address
Do
If sh.Cells(k.Row, "AC").Value > 0 Then
Cells(sat1, "A").Value = k.Value
Cells(sat1, "B").Value = sh.Cells(k.Row, "W").Value
Cells(sat1, "C").Value = sh.Cells(k.Row, "AZ").Value
Cells(sat1, "D").Value = sh.Cells(k.Row, "B").Value
Cells(sat1, "E").Value = sh.Cells(k.Row, "BB").Value
Cells(sat1, "F").Value = sh.Cells(k.Row, "D").Value
Cells(sat1, "G").Value = sh.Cells(k.Row, "F").Value
Cells(sat1, "H").Value = sh.Cells(k.Row, "H").Value
Cells(sat1, "I").Value = sh.Cells(k.Row, "AN").Value
Cells(sat1, "J").Value = sh.Cells(k.Row, "J").Value
Cells(sat1, "K").Value = sh.Cells(k.Row, "T").Value
Cells(sat1, "L").Value = sh.Cells(k.Row, "U").Value
Cells(sat1, "M").Value = sh.Cells(k.Row, "AD").Value
Cells(sat1, "N").Value = sh.Cells(k.Row, "AM").Value
Cells(sat1, "O").Value = sh.Cells(k.Row, "BC").Value
Cells(sat1, "P").Value = sh.Cells(k.Row, "AF").Value
Cells(sat1, "Q").Value = sh.Cells(k.Row, "E").Value
Cells(sat1, "R").Value = sh.Cells(k.Row, "AB").Value
Cells(sat1, "S").Value = sh.Cells(k.Row, "AU").Value
Cells(sat1, "T").Value = sh.Cells(k.Row, "AV").Value
Cells(sat1, "U").Value = sh.Cells(k.Row, "BF").Value
Cells(sat1, "V").Value = sh.Cells(k.Row, "BG").Value
Cells(sat1, "W").Value = sh.Cells(k.Row, "BH").Value
Cells(sat1, "AC").Value = sh.Cells(k.Row, "BA").Value
sat1 = sat1 + 1
End If
Set k = sh.Range("V2:A" & sat2).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
End Sub

 

[zafer]

Merhaba


For i=1 to 50

sayfa=sheets("TRD").cells(i,"A")

do
sheets(sayfa).Cells(sat1, "B").Value = sh.Cells(k.Row, "W").Value
.....
.....
....

Loop While Not k Is Nothing And k.Address <> adr
End If

next
........
.......

End sub

eğer kitaptaki bütün sayfaları işleme alacaksanız.

For i = 1 To Sheets.Count
If Sheets(i).Name <> "TEMIZ" Then

do
sheets(i).Cells(sat1, "B").Value = sh.Cells(k.Row, "W").Value
.....




Arama motoruna sheets.count yazarak aratınız

 

[ExcelF1]

Dosyanızın yedeğini alarak, aşağıdaki şekilde bir deneyin.

Sub TRD_BER()
Dim sh As Worksheet, sat1 As Long, sat2 As Long
Dim k As Range, adr As String
For a = 1 to worksheets.count
Sheets(a).select
'Sheets("TRD-BER").Select
Application.ScreenUpdating = False
Range("A3:W" & Rows.Count).ClearContents
Range("AC3:AC" & Rows.Count).ClearContents
Set sh = Sheets("TEMIZ")
sat2 = sh.Cells(Rows.Count, "V").End(xlUp).Row
Set k = sh.Range("V2:V" & sat2).Find(Range("CC2").Value, , xlValues, xlWhole)
sat1 = 3
If Not k Is Nothing Then
adr = k.Address
Do
If sh.Cells(k.Row, "AC").Value > 0 Then
Cells(sat1, "A").Value = k.Value
Cells(sat1, "B").Value = sh.Cells(k.Row, "W").Value
Cells(sat1, "C").Value = sh.Cells(k.Row, "AZ").Value
Cells(sat1, "D").Value = sh.Cells(k.Row, "B").Value
Cells(sat1, "E").Value = sh.Cells(k.Row, "BB").Value
Cells(sat1, "F").Value = sh.Cells(k.Row, "D").Value
Cells(sat1, "G").Value = sh.Cells(k.Row, "F").Value
Cells(sat1, "H").Value = sh.Cells(k.Row, "H").Value
Cells(sat1, "I").Value = sh.Cells(k.Row, "AN").Value
Cells(sat1, "J").Value = sh.Cells(k.Row, "J").Value
Cells(sat1, "K").Value = sh.Cells(k.Row, "T").Value
Cells(sat1, "L").Value = sh.Cells(k.Row, "U").Value
Cells(sat1, "M").Value = sh.Cells(k.Row, "AD").Value
Cells(sat1, "N").Value = sh.Cells(k.Row, "AM").Value
Cells(sat1, "O").Value = sh.Cells(k.Row, "BC").Value
Cells(sat1, "P").Value = sh.Cells(k.Row, "AF").Value
Cells(sat1, "Q").Value = sh.Cells(k.Row, "E").Value
Cells(sat1, "R").Value = sh.Cells(k.Row, "AB").Value
Cells(sat1, "S").Value = sh.Cells(k.Row, "AU").Value
Cells(sat1, "T").Value = sh.Cells(k.Row, "AV").Value
Cells(sat1, "U").Value = sh.Cells(k.Row, "BF").Value
Cells(sat1, "V").Value = sh.Cells(k.Row, "BG").Value
Cells(sat1, "W").Value = sh.Cells(k.Row, "BH").Value
Cells(sat1, "AC").Value = sh.Cells(k.Row, "BA").Value
sat1 = sat1 + 1
End If
Set k = sh.Range("V2:A" & sat2).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation
End Sub

 

[Barfly]

Sayın Excel,

Bu çalışma sayfasında data ve benzeri sayfalar da mevcut sanırım bu kod tüm sayfaları da etkileyecek. Ben bu sebeple sayfa isimlerinin bulunduğu bir listeden sorgular diye düşünmüştüm.

Sayın Zafer,

Desteğiniz için çok teşekkürler fakat iyi olmadığım için kodu nasıl toparlayacağımı anlayamadım.

 

[ExcelF1]

For satırındaki kodu şu şekilde revize ederek dener misiniz.
Kodun çalışmasını istediğiniz sayfa isimlerini yeni bir sayfada ve A sütununda toplayarak,

For a = 1 To Sheets("YeniBirSayfa").[A65536].End(xlUp).Row
Sheets(Sheets("YeniBirSayfa").Cells(a, 1).Value).Select

 

[Barfly]

Sayın ExcelF1,

TRD sayfası oluşturup A1 den A4 arası aşağıdaki isimleri yadım ve herbiri için sheet oluştudum. TRD-BER çalışıyor, geri kalan 3 sayfayada TRD-MKA ya ait veriyi getiriyor neden olabilir?

TRD-BER
TRD-FTO
TRD-FDE
TRD-MKA

Teşekkürler,

 

[Barfly]

Sayın ExcelF1,

Benim hatam olduğunu farkettim sorun çözüldü yardımlarınız için çok teşekkür ederim.

 

[ExcelF1]

Rica ederim, kolay gelsin.