KOŞULLU FORMÜL YAPIŞTIRMA, KOŞULLU FORMÜL ÇOĞALTMA

[coşkun79]

Ekli dosyada bulunan iki adet sayfada iki farklı koşula göre formül yapıştırma seçeneğini ben makro kaydet yöntemi ile yaptım. Ancak koşula göre her defasında makroyu değiştirmem gerekiyor. Bunun yerine söz konusu makroların koşulları otomatik algılamasını sağlayacak şekilde değiştirmek istiyorum.

1. sayfadaki koşul: A:G arasındaki satırlarda en az bir adet veri varsa H2:J2 aralığının formülünü kopyalayıp yapıştırmak
2. sayfadaki koşul: A sütununda veri varsa (A sütunu boş değilse) H2:J2 aralığının formülünü kopyalayıp yapıştırmak

------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Not 1: Yapıştırılacak doğru alanları sarıya boyadım.
Not 2: H2:J2 aralığında dizi formülü varsa aynı satıra yapıştırmak sorun olacağından, yapıştırmayı üçüncü satırdan başlattım.
Not 3: Yapıştır işlemini, hücreyi kopyala + formülü yapıştır şeklinde yapmak istiyorum. Çünkü makronun içine formularay şeklinde formülü yazarsam her seferinde makrodaki formülü değiştirmek gerekecek.

 

[Ömer]

Merhaba,

İstediğiniz bu mu?

Sub TEST_1()
 
    Dim son As Long, i As Long, a As Byte

    son = [A:G].Find("*", , , , xlByRows, xlPrevious).Row

    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
   
    Range("H3:J" & Rows.Count).ClearContents
    If son < 3 Then Exit Sub
 
    For i = 3 To son
        a = WorksheetFunction.CountA(Range("A" & i & ":G" & i))
        If a > 0 Then
            Range("H2:J2").Copy
            Cells(i, "H").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone
        End If
    Next i
   
    [H1].Select
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With   
 
End Sub

Sub TEST_2()

    Dim son As Long, i As Long

    son = [A:G].Find("*", , , , xlByRows, xlPrevious).Row
 
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
    End With
   
    Range("H3:J" & Rows.Count).ClearContents
    If son < 3 Then Exit Sub
 
    For i = 3 To son
        If Cells(i, "A") <> "" Then
            Range("H2:J2").Copy
            Cells(i, "H").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone
        End If
    Next i
   
    [H1].Select
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .Calculation = xlAutomatic
    End With

End Sub

 

[coşkun79]

Gayet güzel olmuş. Elinize sağlık Ömer Bey. Saygılar