Verileri başka sütuna alma

[husocan005]

Arkadaşlar yardımlarınız için şimdiden teşekkür ederim açıklamalar excelde mevcuttur.


http://dosya.co/eeot7vunarva/deneme.xlsx.html

 

[antonio]

Merhaba,
Örnek dosyanız açık iken Alt+F11 (Alt tuşunu basılı tutarak F11 'i tuşlamak) ile açılan kod penceresine aşağıdaki kodları yapıştırarak çalıştırınız.

Sub kopyala_ve_sil()
Sayfa1.Range("A8").Value = Sayfa1.Range("A2").Interior.Color
Dim renk As Long, hcr As Range, sh As Worksheet, ss As Long, renkli As Range

renk = 8210719
Set sh = Sayfa1
ss = sh.Range("C" & Rows.Count).End(3).Row

For i = ss To 2 Step -1
    If sh.Range("A" & i).Interior.Color = renk Then
        sh.Range("A" & i).EntireRow.Insert xlUp
    End If
Next i
ss = sh.Range("C" & Rows.Count).End(3).Row
cc = sh.Cells(1, Columns.Count).End(xlToLeft).Column
    For d = cc To 2 Step -2
        For a = ss To 1 Step -2
            Set renkli = sh.Cells(a, d)
            renkli.Copy renkli.Offset(1, -1)
                If renkli.Interior.ColorIndex <> 6 Then
                    a = a - 2
                    GoTo atla
                End If
        Next a
sil:
        sh.Columns(d).EntireColumn.Delete
atla:
    Next d
MsgBox "işlem tamamlandı", vbInformation, Application.UserName
End Sub