makro ile biçimlendirme

[spacebar]

Değerli dostlarım. bir sorunum var. yardımcı olursanız sevinirim. yapmak istediğim:
A sütununda veri varsa; A ile F sütununda veri olan satırlarda şu makroyu uygulasın :

Sub bicimlendir()
Range("M1:R1").Select
Selection.Copy
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A2:F2001").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
End Sub

yani yapmak istediğim A2 den A50 satırına kadar değer varsa A2:F50 hücrelerinde yukarıdaki makroyu uygulasın.
yardımlarınız için şimdiden teşekkür ederim.

 

[Ömer]

Merhaba,

Sorunuz net değil, istediğiniz bu mu?

Sub bicimlendir()

    Dim i As Integer
    
    Application.ScreenUpdating = False
    
    For i = 2 To 50
        If Cells(i, "A") <> "" Then
            Range("M1:R1").Copy
            Range("A" & i & ":F" & i).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
        End If
    Next i

    Application.CutCopyMode = False
    Range("A1").Select
    
End Sub

 

[spacebar]

üstad ellerinize sağlık. tam olarak istediğim buydu. ben önce yapmaya çalışıyorum. uzun uğraşlardan sonra yapamazsam foruma yazıyorum. sorunu çözmenin yanında öğrenmeye çalışıyorum. sayenizde yeni bir şey öğrendim. teşekkür ederim.

 

[Ömer]

Önemli değil.
Ek bilgi; A sütununda veri varsa biçimlendirme yaptıktan sonra veriyi silmeniz gerektiği zaman kodları çalıştırsanız bile biçim yine M1:R1 deki olarak kalır. Çünkü kodlarda düzeltilecek bir biçim örneği yok.
Bu sorun olacaksa M1:R1 gibi bir aralık belirleyip boş olursa olması gereken biçim bu aralık olacak şekilde bir işlem yapılmasında fayda var.

Biraz karışık yazmış olabilir, umarım anlatabildim.

Örnek kodar aşağıdadır. Örnek boş biçim alanı M2:R2 olsun:

Sub bicimlendir()

    Dim i As Integer
    
    Application.ScreenUpdating = False
    
    Range("M2:R2").Copy
    Range("A2:F50").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
    
    For i = 2 To 50
        If Cells(i, "A") <> "" Then
            Range("M1:R1").Copy
            Range("A" & i & ":F" & i).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
        End If
    Next i

    Application.CutCopyMode = False
    Range("A1").Select
    
End Sub

 

[spacebar]

evet üstad. daha az veri olduğundaki durumu test etmemiştim. bunu gözden kaçırmışım. bu kodlar çalışmama daha uygun. teşekkür ederim.