boşluk bırakarak kopyalama

[asubsubaru]

ustalar kolay gelsin bbb sayfasındaki veriyi aaa sayfasındaki sarıyla boyalı kısma değerler ve sayı biçimleri sabit kalacak şekilde kopyalamak istiyorum.

fakat bu olayı wtg30 değerini otomatik bulup 3 satır boş yer bırakıp kopyalama yapmasını istiyorum bunu nası yapabilirim

 

[Korhan Ayhan]

Selamlar,

Örnek dosyanızdaki veriye göre 3 satır değil 7 satır ekleyerek sarı renkli alana ulaşabilirsiniz. Aşağıdaki kod bu şekilde çalışmaktadır. Eğer siz 3 satır sonrası olsun diyorsanız. Koddaki kırmızı bölüme 4 yazınız.

Option Explicit
 
Sub KOPYALA()
    Dim S1 As Worksheet, S2 As Worksheet, Satır As Long
 
    Set S1 = Sheets("bbb")
    Set S2 = Sheets("aaa")
 
    Satır = Evaluate("=MAX((" & S2.Name & "!A1:A1000=""WTG30"")*(ROW(1:1000)))")
 
    If Satır > 0 Then
        S1.Range("C1:D1").Copy
        S2.Cells(Satır + [COLOR=red]7[/COLOR], "D").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
    End If
 
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[asubsubaru]

teşekkür ediyorum elinize sağlık başka bir sorum daha olacak

verdiğiniz formülü

mevcut formülün altına ekleyip son olarak devreye girmesini nasıl sağlayabilirim

Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
For a = Sheets.Count To 1 Step -1
ad = Sheets(a).Name
If ad <> "Report" And ad <> "hesap" And ad <> "Ekle" And ad <> "total" Then Sheets(a).Delete
Next
On Error Resume Next
Set sh = Sheets("sonuc")
If sh Is Nothing Then
Sheets("report").Copy _
after:=Sheets(Sheets.Count)
ActiveSheet.Name = "sonuç"
Set S1 = Sheets("sonuç")
Set S2 = Sheets("ekle")
For a = 1 To S2.[b65536].End(3).Row
If S2.Cells(a, "a") <> "" Then
c = c + 1
sonn = 0
deger = S2.Cells(a, "a")
ilk = WorksheetFunction.Match(deger, S1.[a:a], 0)
sonn = WorksheetFunction.CountIf(S1.[a:a], deger) + ilk
End If
S1.Rows(sonn).Insert Shift:=xlDown
S1.Cells(sonn, "d").NumberFormat = S2.Cells(a, "d").NumberFormat
S1.Cells(sonn, "d") = S2.Cells(a, "d")
S1.Cells(sonn, "e").NumberFormat = S2.Cells(a, "e").NumberFormat
S1.Cells(sonn, "e") = S2.Cells(a, "e")
If c = 1 Then
S1.Cells(sonn, "a") = deger
c = 0
End If
sonn = sonn + 1
Next
End If
End Sub

 

[asubsubaru]

birde üstat birşey dikkatimi çekti kopyalamanın gerçekleşmesi için aaa sayfasında olmak gerekiyor bbb sayfasında iken kopyalama gerçekleşmiyor hangi sayfada olursa olsun kopyalayacak şekilde yapmak mümkünmü

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.