Soru Kolonları tek hücrede nasıl birleştirebilirim?

[Mukteda]

.
.
Merhaba,

Ekteki çalışma sayfasında mevcut durum sayfasında, 49 sütün tek hücrede alt alta nasıl birleştirebilirim?

Teşekkürler, kolay gelsin.

SÜTUN BİRLEŞTİR.xlsx - 15 KB

 

[dost]

Merhaba,

Office 365 ile;

AY1 hücresine,

=TEXTJOIN(CHAR(10);TRUE;A:AW)

Sonrasında AZ1 hücresine AY1 hücresini kopyalayıp değer yapıştır yaparsınız. AZ1 hücresinde değerler alt alta gözükecektir.

 

[Mukteda]

Merhaba,

Office 365 ile;

Merhabalar,

İlginiz ve dğerli yardımınız için teşekkür ederim.

İş yerinde Office 2010 kullanıyorum. Malum patronlar...

Şahsi Office 365 hesabımda kontrol ettiğimde ise #AD? Hatası verdi...

VBA ile nasıl yapabilirim?

 

[Korhan Ayhan]

İnceleyiniz.

Sorgu için arama sonuçları: K_BİRLEŞTİR

www.excel.web.tr

 

[ÖmerFaruk]

VBA ile
Aşağıdaki kodları boş bir modüle kopyalayın ve çalıştırın.
Sayfa isimleriniz farklıysa değiştirebilrisiniz.

Sub SutunBirlestir()
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim Veri
    Set Sh1 = Worksheets("MEVCUT DURUM")  ' Sayfa isimlerinizi değiştirebilrisiniz'
    Set Sh2 = Worksheets("OLMASI İSTENEN")' Sayfa isimlerinizi değiştirebilrisiniz'
    Veri = Sh1.Range("A1").CurrentRegion.Value
    ReDim Liste(1 To UBound(Veri, 1) * 3, 1 To 1)
    For i = 1 To UBound(Veri, 1)
        Liste((i - 1) * 3 + 1, 1) = Veri(i, 1)
        Metin = ""
        For k = 2 To UBound(Veri, 2)
            If Veri(i, k) <> "" Then Metin = Metin & Veri(i, k) & Chr(10)
        Next k
        If Metin <> "" Then
            Metin = Left(Metin, Len(Metin) - 1)
            Liste((i - 1) * 3 + 2, 1) = Metin
        End If
    Next i
    Sh2.Cells.ClearContents
    Sh2.Range("A1").Resize(UBound(Veri, 1) * 3, 1) = Liste
    Sh2.Range("A:A").RowHeight = 14.4
    Sh2.Cells.RowHeight = 14.4
    For i = 1 To UBound(Veri, 1) * 3 Step 3
        Sh2.Range("A" & i).HorizontalAlignment = xlHAlignCenter
        Sh2.Range("A" & i).Font.Bold = True
        Sh2.Range("A" & i + 1).RowHeight = 100
    Next i
End Sub

 

[Mukteda]

İnceleyiniz.

Değerli Korhan Hocam,
O konuları gördüm ama bizim mesele biraz çetrefilli olduğundan yeni konu açmak durumunda kaldım.
İlginiz için teşekkür ederim.

VBA ile
Aşağıdaki kodları boş bir modüle kopyalayın ve çalıştırın.

Ömer Bey merhaba,
Tek seferde nokta atışı bu sanırım...
İllallah ettirmeden... Bıktırmadan... Hızlıca...
Çok teşekkür ederim, işleriniz rast gitsin.
Hakkınızı helal ediniz.

 

[dost]

Merhaba,

Denersiniz.

NOT: Benden önce cevaplar yazılmış. Benimki de alternatif olsun.

Sub Test()
    
Dim s1 As Worksheet, s2 As Worksheet
    Dim lRow As Long, lCol As Integer
    Dim sourceRng  As Range
    Dim myStr As String

    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    
    lRow = s1.UsedRange.Rows(s1.UsedRange.Rows.Count).Row
    lCol = s1.Cells(1, s1.Columns.Count).End(xlToLeft).Column
    
    Set sourceRng = s1.Range(s1.Cells(1, 1), s1.Cells(lRow, lCol))

    myStr = WorksheetFunction.TextJoin(Chr(10), True, s1.Range(sourceRng.Address))
   
    s2.Range("A1") = myStr
    
  
    Set s1 = Nothing:   Set s2 = Nothing:   Set sourceRng = Nothing
    
    MsgBox "İşlem tamam..."

End Sub

 

[Mukteda]

Merhaba,

Denersiniz.

NOT: Benden önce cevaplar yazılmış. Benimki de alternatif olsun.

Merhabalar,

Tamamdır. İlginiz için teşekkür ederim. Kolay gelsin.

 

[Tevfik_Kursun]

Sayın Dost,
Makronuz bende hata verdi. Neden olabilir?
Saygılarımla

 

[dost]

Merhaba,

Büyük ihtimalle TextJoin fonksiyonu sende çalışmıyor.

O nedenle aşağıdaki kodu dener misiniz.

Sub Test_1()
    Dim s1 As Worksheet, s2 As Worksheet
    Dim lRow As Long, lCol As Integer
    Dim sourceRng  As Range
    Dim myStr As String
  
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    
    lCol = s1.Cells(1, s1.Columns.Count).End(xlToLeft).Column
      
    For i = 1 To lCol
        lRow = s1.Cells(s1.Rows.Count, i).End(xlUp).Row
        Set sourceRng = s1.Range(s1.Cells(1, i), s1.Cells(lRow, i))
        myStr = IIf(i = 1, Join(Application.Transpose(s1.Range(sourceRng.Address).Value), Chr(10)), _
                myStr & Chr(10) & Join(Application.Transpose(s1.Range(sourceRng.Address).Value), Chr(10)))
    Next i
  
    s2.Range("C1") = myStr
 
    Set s1 = Nothing:   Set s2 = Nothing:   Set sourceRng = Nothing
    
    MsgBox "İşlem tamam..."

End Sub