Soru düzenli bir şekilde; bir hücre içindeki metni başka bir (birleştirilmiş) hücre grubuna taşımak yada kopyalama resimlerde açıklama var

[salimteker]

resim1
resim2

yardımlarınız için şimdiden teşekkürler. resimleri umarım görebiliyorsunuzdur. kolay gelsin

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Test()
    Dim X As Long
    
    For X = 2 To Cells(Rows.Count, "N").End(3).Row Step 3
        If Cells(X, "N") <> "" Then
            Cells(X + 1, 1) = Cells(X, "N")
            Cells(X + 1, 1).Font.Size = Cells(X, "N").Font.Size
            Cells(X + 1, 1).Font.Bold = Cells(X, "N").Font.Bold
            Cells(X + 1, 1).Font.Color = Cells(X, "N").Font.Color
            Cells(X, "N") = ""
        End If
    Next
    
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

 

[salimteker]

Deneyiniz.

Option Explicit

Sub Test()
    Dim X As Long
  
    For X = 2 To Cells(Rows.Count, "N").End(3).Row Step 3
        If Cells(X, "N") <> "" Then
            Cells(X + 1, 1) = Cells(X, "N")
            Cells(X + 1, 1).Font.Size = Cells(X, "N").Font.Size
            Cells(X + 1, 1).Font.Bold = Cells(X, "N").Font.Bold
            Cells(X + 1, 1).Font.Color = Cells(X, "N").Font.Color
            Cells(X, "N") = ""
        End If
    Next
  
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

N2 ----> AM3 birleştirilmişe taşındı lakin bazılarında oldu
sadece N2, N8, N14, N20 ......... dizisinde oldu. N4, N6, N10, N12, N16, N18.......... dizisinde olmadı.

 

[Korhan Ayhan]

Paylaştığınız görselde satırlar düzenli artıyordu. Uyguladığınız dosyanızda bu durum farklı ise sonuç almamaniz normaldir.

Örnek dosyanızı paylaşırsanız kodu ona göre revize edebilirim. Paylaşım sitelerine örnek dosyanızı yükleyip linkini forumda paylaşabilirsiniz.

 

[salimteker]

Paylaştığınız görselde satırlar düzenli artıyordu. Uyguladığınız dosyanızda bu durum farklı ise sonuç almamaniz normaldir.

Örnek dosyanızı paylaşırsanız kodu ona göre revize edebilirim. Paylaşım sitelerine örnek dosyanızı yükleyip linkini forumda paylaşabilirsiniz.

bana verilen excel de iki değişiklik yapacağım.
1. ilk satır hariç sonraki satırların herbirinin arasına A dan N ye kadar (N dahil değil) birleştirilmiş tek hücre oluşturarak eklemek.
2. N sütunundaki Metin leri sırasıyla 1.de oluşturulan birleştirilmiş tek hücreye sırasıyla taşımak. Sonunda tabloyu A dan M ye kadar (M sütunu dahil) kullanmak yani N sütunu işlemin en sonunda sileceğim. Umarım açıklayıcı olurken akıl karıştırmamışımdır. Teşekkürler , Kolay gelsin
excel dosyasının öncesi
excel dosyasının son hali

 

[salimteker]

bana verilen excel de iki değişiklik yapacağım.
1. ilk satır hariç sonraki satırların herbirinin arasına A dan N ye kadar (N dahil değil) birleştirilmiş tek hücre oluşturarak eklemek.
2. N sütunundaki Metin leri sırasıyla 1.de oluşturulan birleştirilmiş tek hücreye sırasıyla taşımak. Sonunda tabloyu A dan M ye kadar (M sütunu dahil) kullanmak yani N sütunu işlemin en sonunda sileceğim. Umarım açıklayıcı olurken akıl karıştırmamışımdır. Teşekkürler , Kolay gelsin
excel dosyasının öncesi
excel dosyasının son hali

Korhan bey paylaştım Excel dosyasını öncesi ve sonrası diye, görmemiş olabilirsiniz diye hatırlatma yapayım dedim. İyi çalışmalar.

 

[Korhan Ayhan]

Evet sizin konu arada kaynamış. Gözümden kaçmış. Dosyanıza göre kodu revize edip birazdan paylaşırım.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Baslik_Ekle()
    Dim Metin As Variant, X As Long, Satir As Long, Son As Long

    Application.ScreenUpdating = False

    Range("A2:M" & Rows.Count).UnMerge
    
    Son = Cells(Rows.Count, "N").End(3).Row
    Metin = Range("N2:N" & WorksheetFunction.Max(3, Son)).Value
    
    Satir = 3
    
    For X = LBound(Metin, 1) To UBound(Metin, 1)
        Range("A" & Satir & ":M" & Satir).Merge True
        Range("A" & Satir) = Metin(X, 1)
        Range("A" & Satir).Font.Name = "Verdana"
        Range("A" & Satir).Font.Size = 16
        Range("A" & Satir).Font.Bold = True
        Satir = Satir + 2
    Next
    
    Range("N2:N" & Rows.Count).ClearContents
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[salimteker]

gönderdiğim excel tablosundaki veri eksikliğinden kaynaklı Sizi yanılttı. Sizin yazdığınız makro bazı satırları siliyor. varsayılan excel tablonun içini doldurarak güncelledim. Makro sonucunu da payklaştım ve olması gerekeni de. hepsini ekte paylaşıyorum sırayla. Yardımlarınız için teşekkürler, iyi çalışmalar..
excelvarsayılan
excel_makro_uygulanınca
excel_olması_gereken

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Baslik_Ekle()
    Dim Alan As Range, Metin As Variant, X As Long, Satir As Long, Son As Long

    Application.ScreenUpdating = False

    Son = Cells(Rows.Count, "N").End(3).Row
    Metin = Range("N2:N" & WorksheetFunction.Max(3, Son)).Value
   
    Range("A2:M" & Rows.Count).UnMerge
    On Error Resume Next
    Set Alan = Nothing
    Set Alan = Intersect(Range("A:M"), Range("B2:B" & Cells(Rows.Count, 1).End(3).Row).SpecialCells(4).EntireRow)
    On Error GoTo 0
   
    If Not Alan Is Nothing Then Alan.Delete xlUp
   
    Satir = 3
   
    For X = LBound(Metin, 1) To UBound(Metin, 1)
        If Metin(X, 1) <> "" Then
            Range("A" & Satir).EntireRow.Insert
            Range("A" & Satir & ":M" & Satir).Merge True
            Range("A" & Satir) = Metin(X, 1)
            Range("A" & Satir).Font.Name = "Verdana"
            Range("A" & Satir).Font.Size = 16
            Range("A" & Satir).Font.Bold = True
        End If
        Satir = Satir + 2
    Next
   
    Range("N2:N" & Rows.Count).ClearContents
   
    Set Alan = Nothing

    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[salimteker]

Makro tam olarak çalıştı. Ellerine, Yüreğine sağlık..

 

[Korhan Ayhan]

Kodun bitimine bir satır ekledim. Dilerseniz son halini kullanınız.