Sayfalardaki kodları modüle alma

[vivident]

Merhaba

Merhaba dosyamdaki her sayfada aşağıdaki kodlar var. Tek tek sayfalara girip makroları çalıştırıyorum. Bu makrolar modüle alınıp tek bir tuşla tüm sayfalarda makrolar çalışabilir mi ?

Sub On_aktar()
Dim STR As Long, ben As Long
With WorksheetFunction
STR = .Match(Range("D1"), _
Range("M1:X1"), 0) + 13
ben = Cells(1, STR).End(3).Row
Range("D6").Copy
Cells(6, STR).PasteSpecial (xlPasteValues)
Range("D11").Copy
Cells(11, STR).PasteSpecial (xlPasteValues)
Range("D15").Copy
Cells(15, STR).PasteSpecial (xlPasteValues)
Range("D19").Copy
Cells(19, STR).PasteSpecial (xlPasteValues)
Range("D23").Copy
Cells(23, STR).PasteSpecial (xlPasteValues)
Range("D27").Copy
Cells(27, STR).PasteSpecial (xlPasteValues)
Range("D31").Copy
Cells(31, STR).PasteSpecial (xlPasteValues)
Range("D35").Copy
Cells(35, STR).PasteSpecial (xlPasteValues)
Range("D39").Copy
Cells(39, STR).PasteSpecial (xlPasteValues)
Range("D43").Copy
Cells(43, STR).PasteSpecial (xlPasteValues)
Range("D47").Copy
Cells(47, STR).PasteSpecial (xlPasteValues)
Range("D51").Copy
Cells(51, STR).PasteSpecial (xlPasteValues)
Range("D55").Copy
Cells(55, STR).PasteSpecial (xlPasteValues)
Range("D59").Copy
Cells(59, STR).PasteSpecial (xlPasteValues)
Range("D63").Copy
Cells(63, STR).PasteSpecial (xlPasteValues)
Range("D67").Copy
Cells(67, STR).PasteSpecial (xlPasteValues)
End With
Application.CutCopyMode = False
End Sub

 

[PLİNT]

Merhaba

Merhaba dosyamdaki her sayfada aşağıdaki kodlar var. Tek tek sayfalara girip makroları çalıştırıyorum. Bu makrolar modüle alınıp tek bir tuşla tüm sayfalarda makrolar çalışabilir mi ?

Merhaba

Sayfalardan herhangi birine ekleyeceğiniz butona aşağıdaki gibi eklerseniz;
bütün sayfalara yukarıdaki kodu (döngüyle kısaltılmışı) uygulayacaktır.

Private Sub CommandButton1_Click()
   'Sub On_aktar()
Dim STR As Long, ben As Long
Application.ScreenUpdating = False
[COLOR="Blue"]For x = 1 To Worksheets.Count[/COLOR]
With WorksheetFunction
STR = .Match(Sheets(x).Range("D1"), _
Sheets(x).Range("M1:X1"), 0) + 13
ben = Sheets(x).Cells(1, STR).End(3).Row
Sheets(x).Range("D6").Copy
Sheets(x).Cells(6, STR).PasteSpecial (xlPasteValues)
For n = 11 To 67
Sheets(x).Range("D" & n).Copy
Sheets(x).Cells(n, STR).PasteSpecial (xlPasteValues)
n = n + 3
Next
End With
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub

 

[vivident]

Sayın PLINT
Ben yapamadım sanırım 400 kodu veriyor
Dosyam ektedir

 

[PLİNT]

Merhaba
Örnek dosyanızı http://s3.dosya.tc/ ekleyip link verirmisiniz?

 

[vivident]

http://s3.dosya.tc/server6/ve4n43/soru__1_.zip.html

 

[PLİNT]

Merhaba
Örneğinizde kodların uygulanmayacağı iki sayfa bulunuyormuş. Hata vermiş.
İki sayfayı ("Lup" ve "Gelişim") aşağıdaki şekilde atlayabilir. Kodlarınıza aşağıdaki kırmızı satırları ekleyip denermisiniz?

 Sub DENEME()
Dim STR As Long, ben As Long
Application.ScreenUpdating = False
For x = 1 To Worksheets.Count
[COLOR="Red"]If Sheets(x).Name <> "Lup" And Sheets(x).Name <> "Gelişim" Then[/COLOR]
With WorksheetFunction
STR = .Match(Sheets(x).Range("D1"), _
Sheets(x).Range("M1:X1"), 0) + [COLOR="RoyalBlue"]13[/COLOR]
ben = Sheets(x).Cells(1, STR).End(3).Row
Sheets(x).Range("D6").Copy
Sheets(x).Cells(6, STR).PasteSpecial (xlPasteValues)
For n = 11 To 67
Sheets(x).Range("D" & n).Copy
Sheets(x).Cells(n, STR).PasteSpecial (xlPasteValues)
n = n + 3
Next
End With
Application.CutCopyMode = False
[COLOR="Red"]End If[/COLOR]
Next
Application.ScreenUpdating = True
End Sub

Bu arada; yukarıdaki (mavi) "13" , "12" olması gerek değilmi?
"Gelişim" "B3" 1 olduğunda "Şubat" ayına kopyalıyor.