Seçtiğim Alanı Kopyalayıp Farklı Hücrelere Yapıştırma

[Korhan Ayhan]

Deneyiniz.

İstediğiniz sayfada B sütununda aktarmak istediğiniz hücreleri seçip kodu çalıştırıp deneyiniz.

Option Explicit

Sub Secimi_Aktar()
    Dim Alan As Range, S1 As Worksheet, Son As Long
    Dim X As Long, Veri As Range, Satir As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("BLOKE KARTI")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    For X = 5 To Son Step 14
        S1.Range("F" & X & ":J" & X).ClearContents
        S1.Range("D" & X + 2 & ":J" & X + 2).ClearContents
        S1.Range("D" & X + 4 & ":E" & X + 4).ClearContents
        S1.Range("G" & X + 4 & ":H" & X + 4).ClearContents
        S1.Range("J" & X + 4 & ":J" & X + 4).ClearContents
        S1.Range("D" & X + 6 & ":H" & X + 6).ClearContents
        S1.Range("J" & X + 6 & ":J" & X + 6).ClearContents
        S1.Range("E" & X + 8 & ":F" & X + 8).ClearContents
    Next

    
    Set Alan = Selection
    
    If Intersect(Alan, Range("B4:B" & Rows.Count)) Is Nothing Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        MsgBox "Lütfen B sütunundan seçim yapınız!" & vbLf & vbLf & _
               "İşleminiz iptal edilmiştir!", vbCritical
        Exit Sub
    End If
    
    If Alan.Parent.Name = S1.Name Then
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        MsgBox "Lütfen " & S1.Name & " isimli sayfa dışında bir sayfada B sütunundan seçim yapınız!" & vbLf & vbLf & _
               "İşleminiz iptal edilmiştir!", vbCritical
        Exit Sub
    End If
    
    Satir = 5
        
    For Each Veri In Alan.Columns(1).Cells
        If Veri.Value <> "" Then
            If Veri.Row > 3 And Veri.Column = 2 Then
                S1.Cells(Satir, "F") = Veri.Offset(0, 0).Value
                S1.Cells(Satir + 6, "J") = Veri.Offset(0, 1).Value
                S1.Cells(Satir + 4, "D") = Veri.Offset(0, 2).Value
                S1.Cells(Satir + 2, "D") = Veri.Offset(0, 3).Value
                S1.Cells(Satir + 8, "E") = Veri.Offset(0, 4).Value
                S1.Cells(Satir + 4, "G") = Veri.Offset(0, 5).Value
                S1.Cells(Satir + 4, "J") = Veri.Offset(0, 6).Value
                Satir = Satir + 14
            End If
        End If
    Next

    Set Alan = Nothing
    Set S1 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

 

[KaraKartall99]

Merhaba Korhan Bey,

Size çok teşekkür ederim makro süper çalışıyor ellerinize sağlık

aynı zamanda Necdet Bey,

Sizede çok teşekkür ederim çok ilgili ve alakalıydınız

Allah ikinizden de razı olsun