Tablo Kopyalama

[hlojan]

Merhaba;

Soldaki tabloları , sağda hedeflenen kısma kopyalamak istiyorum

Belirli tabloları kopyalıyorum. Kopyalarken hedef alandaki kopyalanamaz alanları atlamak istiyorum.
B ile başlıkları ve D ile değerleri tanımlıyorum
Atladıktan sonra , başlarken yarım kalan tablonun başlığı ile başlayıp kalan tablo satırlarını kopyalamaya devam etmek istiyorum

Başlık ve Blok halindeki kısımlar bölünemez

Bir çalışma yaptım ama sonuçlayamadım

Örnek dosyam ekte

Yardımlarınızı bekliyorum

 

[Asri]

Sağdaki tablolar başlıkları ile beraber önceden mi hazırlanıyor?
Sağdaki tablo alanı boş ve program çalıştığında mı hazırlıyor?
Eğer program hazırlıyor ise kullanılamaz alanlar nasıl belirleniyor?

 

[Asri]

Koşullar:
Q sütununda kopyalanmaz satırlar için hücre kırmızı zemin renginde olmalı. Program kopyalanmaz yazısı aramaz
Başlıklar BAŞL ile başlamalı. Siz kod içinde özel karakter tanımlayabilirsiniz. "-" yada ortak bir başlangıç karakteri gibi
BLOK alanının başlık karakterleri BLOK olarak başlamalı.

Program kopyalanmaz satır bulduğunda sonraki yazılacak alanı hesaplar. Yani bir kırmızıdan sonra 4 satır içinde kırmızı olmamalı başlık ve bir veri satırı için varsa program sonraki uygun satırı arar.

Program sağdaki alanı tamamen silip yeniden oluşturmaktadır.

Dim satir As Long
Dim sonsatir As Long
Dim kopyalanmaz As Boolean
Dim baslikrng As Range
'Asri Akdeniz - asriakdeniz@gmail.com - www.asriakdeniz.com

Sub aktar()
   Range("R:Y").Clear
   sonsatir = Cells(Rows.Count, "B").End(3).Row
   sonsatir = ActiveSheet.UsedRange.Rows.Count
   If sonsatir < 3 Then sonsatir = 3
   satir = 2
   For i = 3 To sonsatir
     baslik = Left(Cells(i, "E").Value, 4)
     If baslik = "BLOK" Then
       Range("E" & i).MergeArea.Copy Range("R" & satir)
     ElseIf baslik = "BAŞL" Then
        Set baslikrng = Range("E" & i & ":L" & i + 2)
        satir = satir + 1
        satir = satirbulbaslik(satir)
        baslikrng.Copy Range("R" & satir & ":Y" & satir + 2)
        satir = satir + 2
        i = i + 2
     Else
        say = WorksheetFunction.CountIf(Range("E" & i & ":L" & i), "<>")
        If say > 0 Then
           satir = satir + 1
           satir = satirbulsatir(satir)
           Range("E" & i & ":L" & i).Copy Range("R" & satir & ":Y" & satir)
        End If
     End If
  
   Next i
End Sub

Function satirbulsatir(nerede As Long) As Long
  kopyalanmaz = False
  For j = nerede To sonsatir
    If Cells(j, "Q").Interior.Color <> vbRed And kopyalanmaz = False Then
       satirbulsatir = j
       Exit Function
    ElseIf Cells(j, "Q").Interior.Color <> vbRed And kopyalanmaz Then
       buldu = False
       For j1 = j To j + 3
           If Cells(j1, "Q").Interior.Color = vbRed Then
             buldu = True
             Exit For
           End If
       Next j1
       If buldu = False Then
           baslikrng.Copy Range("R" & j & ":Y" & j + 2)
           satir = j + 3
           satirbulsatir = satir
           Exit Function
       End If
    
    Else
       kopyalanmaz = True
    End If
  Next j
End Function

Function satirbulbaslik(nerede As Long) As Long
  For j = nerede To sonsatir
    If Cells(j, "Q").Interior.Color <> vbRed And Cells(j + 1, "Q").Interior.Color <> vbRed And Cells(j + 2, "Q").Interior.Color <> vbRed And Cells(j + 3, "Q").Interior.Color <> vbRed Then
       satirbulbaslik = j
       Exit Function
    End If
  Next j
End Function

 

[hlojan]

Teşekkürler. Derleyip uyarladım mükemmel oldu. Teşekkürler emeğiniz için