Benim için zor bir soru.Hücre değerlerine göre satır oluşturma ve kopyalama makrosu

[awesper]

Merhaba,
Ekteki excel dosyasında anlatmaya çalıştım gerçekten benim için zor bir konu yardımlarınızı bekliyorum.Özellikle 2 satıra ayırma işi.
Teşekkür ederim üstadlar.

 

[apocalyt]

bir modüle kopyayıp deneyiniz.

Sub daylight()
Application.ScreenUpdating = False
Sheets(2).Range("a2:g10000").ClearContents
For x = 2 To Sheets(1).[a10000].End(3).Row
ben = Split(Sheets(1).Cells(x, 4), ",")
If UBound(ben) >= 1 Then
For y = LBound(ben) To UBound(ben)
Sheets(1).Range("a" & x & ":f" & x).Copy
Sheets(2).Cells(Sheets(2).[a10000].End(3).Row + 1, 1).PasteSpecial
Sheets(2).Cells(Sheets(2).[a10000].End(3).Row, 4) = ben(y)
Next y
Else
Sheets(1).Range("a" & x & ":f" & x).Copy
Sheets(2).Cells(Sheets(2).[a10000].End(3).Row + 1, 1).PasteSpecial
End If
Next x
For x = 2 To Sheets(2).[a10000].End(3).Row
For a = 0 To 4
sen = Array("*a.ş*", "*ltd.*", "*kooperatif*", "*başkanlığı*", "*kollektif*")
If Sheets(2).Cells(x, "d") Like sen(a) Then
Sheets(2).Cells(x, "g") = "Tüzel"
Exit For
End If
Next a
Next x
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "İşleminiz bitmiştir.", vbInformation
End Sub

 

[awesper]

Teşekkürler

Sayın apocalyt yardımlarınız için çok teşekkür ederim.Benim çok işime yaradı.