Satır Ekleme

[maestrocan]

http://dosya.co/1sfji4d7gfru/ornek.xls.html

http://dosya.co/aatj6jzv696p/ornek2.xls.html

merhabalar;

elimde satır ekleme macrosu mevcut.
benim ihtiyaçım olan ise kodlar arasında 12 satır bosluk olacak.
ama macro calıstıgında ornek2 dosyasındaki gibi görünmesi lazım.
bana yardımcı olurmusunuz.

 

[askm]

Sayfa2 ye Başlık kısmını ekleyin. Aşağıdaki kodları kullanabilirsiniz.

Sub ASKM_Veri_Aktar()
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Dim SonSat As Long
s2.Range("A2:H65000").ClearContents
a = 2
SonSat = s1.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To SonSat
    say = WorksheetFunction.CountIf(s1.Range("B2:B" & i), s1.Cells(i, 2))
    If say = 1 Then
        s2.Cells(a, 1) = s1.Cells(i, 1)
        s2.Cells(a, 2) = s1.Cells(i, 2)
        a = a + 12
    End If
Next i

For x = 2 To a
t = x
    For y = 2 To SonSat
        If s2.Cells(x, 1) = s1.Cells(y, 1) Then
            s1.Range("C" & y & ":H" & y).Copy
            s2.Cells(t, 3).PasteSpecial Paste:=xlPasteValues
            t = t + 1
        End If
    Next y
Next x
MsgBox "Aktarma işlemi tamamlandı...", vbInformation, "ASKM"
End Sub

 

[maestrocan]

Öncelikle yapmış olduğunuz macro için teşekkür ederim.
Bu macroda bazı sıkıntılar var bunları düzeltme şansınız varmıdır?
Ekli dosyada yolladığım excelde sayfalarda verilerimi görebilirsiniz.
VERI, MACRO SONUC, OLMASI GEREKEN diye sayfalara ayırdım.
OLMASI GEREKEN sayfasındaki sonucu verecek şekilde düzenleme yapabilirmiyiz.

http://dosya.co/9izmi0varg1x/TEST2.xlsx.html

 

[askm]

Sanırım aşağıdaki şekilde.

Sub ASKM_Veri_Aktar()
Dim s1, s2 As Worksheet
Set s1 = Sheets("VERI")
Set s2 = Sheets("MACRO SONUC")
Dim SonSat As Long
s2.Range("A2:H65000").ClearContents
a = 2
SonSat = s1.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To SonSat
    If s1.Cells(i, "A") <> "" Then
        say = WorksheetFunction.CountIf(s1.Range("B2:B" & i), s1.Cells(i, 2))
            If say = 1 Then
                t = a
                s1.Range("A" & i & ":H" & i).Copy
                s2.Cells(a, 1).PasteSpecial Paste:=xlPasteValues
                 a = a + 12
            End If
    Else
        If s1.Cells(i, "C") <> "" Then
            t = t + 1
            s1.Range("A" & i & ":H" & i).Copy
            s2.Cells(t, 1).PasteSpecial Paste:=xlPasteValues
        End If
    End If
Next i
MsgBox "Aktarma işlemi tamamlandı...", vbInformation, "ASKM"
End Sub