Çalışan bir kodu modifiye etme ?

[Gorarr]

Selamlar. Bu konuda sonuca ulaşmak üzereyim. Excel içerisinde kodlarıyla çalışan iki buton var. Son aşama kodları benzer hücrelere modifiye edemiyorum. Yardımcı olabilirmisiniz. Pek açıklayıcı olmadı ama örnek dosyamda daha iyi açıkladım. Yardımlarınız için şimdiden çok teşekkürler..

 

[leumruk]

Merhaba,
Kodlarınızı aşağıdakilerle değiştirin. Kodlardan birinde değişiklikleri renklendiriyorum.

Sub Sirala()
[COLOR="DarkRed"]Application.ScreenUpdating = False[/COLOR]
karakter = [AD1]
Range("B2:H3").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal
Do While InStr(1, karakter, [B2]) > 0
deg = [B2]
[B2].Delete Shift:=xlToLeft
SonSut = Cells(2, [COLOR="darkred"]8[/COLOR]).End(1).Column + 1  'Bu satır önemli bu satırı iyi inceleyin. 256 yerine alandaki son sütun yazıldı.
[COLOR="darkred"]Cells(2, SonSut).Insert Shift:=xlToRight[/COLOR]
Cells(2, SonSut) = deg
Loop
End Sub

Sub Sirala2()
Application.ScreenUpdating = False
karakter = [AD1]
Range("J5:P5").Sort Key1:=Range("J5"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal
Do While InStr(1, karakter, [j5]) > 0
deg = [j5]
[j5].Delete Shift:=xlToLeft
SonSut = Cells(5, 16).End(1).Column + 1
Cells(5, SonSut).Insert Shift:=xlToRight
Cells(5, SonSut) = deg
Loop
End Sub

Sub Sirala3()
Application.ScreenUpdating = False
karakter = [AD1]
Range("o2:v2").Sort Key1:=Range("o2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal
Do While InStr(1, karakter, [o2]) > 0
deg = [o2]
[o2].Delete Shift:=xlToLeft
SonSut = Cells(2, 22).End(1).Column + 1
Cells(2, SonSut).Insert Shift:=xlToRight
Cells(2, SonSut) = deg
Loop
End Sub

 

[Gorarr]

Çok teşekkür ederim. Ellerinize sağlık. Tamamdır tam istediğim gibi oldu. yaklaşık 60 tane ayrı aralık için tanımladım ve gayet güzel çalışıyor. Saygılar selamlar....