Tek Hücreden Birleştirilmiş Hücreye Veri Kopyalama

[iplikci_80]

Yapmak istediğim şey Kitap1 Sayfa1 C Sütunundaki sicil numaralarının hepsini, Kitap2 Sayfa2'nin B sütunundaki birleştirilmiş hücrelere nasıl kopyalama yapabilirim, bu hususta yardımlarınızı rica ediyorum.

 

[Korhan Ayhan]

İki dosya açıkken aşağıdaki kodu deneyiniz.

Option Explicit

Sub Aktar()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, Veri As Variant
    Dim X As Long, Say As Long
    
    Set K1 = Workbooks("Kitap1.xlsx")
    Set K2 = Workbooks("Kitap2.xlsx")
    Set S1 = K1.Sheets("Sayfa1")
    Set S2 = K2.Sheets("Sayfa2")
    
    S2.Range("B2:B" & S2.Rows.Count).ClearContents

    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son < 4 Then Son = 4
    
    Veri = S1.Range("C3:C" & Son).Value
    
    ReDim Liste(1 To S1.Rows.Count, 1 To 1)

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            If Say = 0 Then
                Say = Say + 1
            Else
                Say = Say + 2
            End If
            Liste(Say, 1) = Veri(X, 1)
        End If
    Next
    
    If Say > 0 Then
        S2.Range("B2").Resize(Say) = Liste
        MsgBox "Aktarım tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If

    Set K1 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub