Farklı kelimelerin arasına 3 satır ekleme

[cengiz123]

Ziynettin hocam,
https://www.dosyaupload.com/lTh3
adresine yükledim.

sayfa 1 de mevcut durum var.
sayfa 2 de ise olması gereken durum.
yalnız işlem yine sayfa 1de olması gerekir. ben sadece karşılaştırma amaçlı farklı sayfalarda yaptım.

H sütununda değerler var.
aynı şekilde bu kodların tekrarsız halleri J sütununda var. K sütununda ise bazı hücrelerde 2ler var.
2 yazan hücrelerin solundaki(J sütunundaki) değeri, H sütununda arayıp bulacak ve daha sonra B-H satırları altına yeni bir satır oluşturacak ve üstteki değeri altına kopyalayacak.
şimdiden çok teşekkür ederim

 

[Ziynettin]

Deneyiniz.

Sub deneme()
Z = TimeValue(Now)
Application.ScreenUpdating = 0
Sheets("Sayfa1").Select
a1 = Range("J2:K" & Cells(Rows.Count, "K").End(3).Row)
Set d = CreateObject("scripting.dictionary")

For i = 1 To UBound(a1)
    If a1(i, 2) = 2 Then
        d(a1(i, 1)) = ""
    End If
Next i

a = Range("B2:H" & Cells(Rows.Count, "B").End(3).Row)
ReDim b(1 To UBound(a) * 2, 1 To UBound(a, 2))

For i = 1 To UBound(a)
    say = say + 1
    For y = 1 To UBound(a, 2)
        b(say, y) = a(i, y)
        b(say + 1, y) = a(i, y)
    Next y
    For Each c In d.keys
        If a(i, 7) = c Then
            say = say + 1
        End If
    Next c
Next i

[B2].Resize(say, UBound(a, 2)) = b
Application.ScreenUpdating = 1
MsgBox "İşlem tamamlandı." & vbLf & vbLf & CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[cengiz123]

Merhaba Ziynettin hocam
Gerçekten ne kadar teşekkür etsem az.
Normalde 1 dakika süren işlem,sizin desteğinize 5sn civarlarına düştü.
Kodunuda bir ekleme yaptım.
Yeni olışturulan satırda, H sütunundski değere _veri2 eklemek için
b(say + 1, y) = a(i, y) komutunun altına
b(say + 1, 7) = a(i, 7) & "_veri2" kodunu ekledim.
Doğru mu yaptım acaba ?
Denedim güzel çalışıyordu.