Listbox seçilmiş verileri tek hücrede birleştirmek?

[ikikan]

Arkadaşlar aşadaki kod ile seçtigim verileri başka bir sayfaya aktarıyorum lakin bir hücrede birleştirmem gerekli yardım ederseniz sevinirim.

Sub PROJE()
Dim ss As Integer, say As Integer, say1 As Integer, say2 As Integer
Dim shf As Worksheet

Set shf = Sheets("PROJE")
ss = shf.Range("B65500").End(3).Row
shf.Range("B2:CV" & ss).ClearContents

say = Sheets("HES").ListBox1.ListCount - 5
For i = 0 To say
If Sheets("HES").ListBox1.Selected(i) = True Then


For e = 1 To 50

shf.Cells(i + 2, 1 + e) = Sheets("VG").Cells(i + 5, e).Text



Next e
End If
Next i


say1 = shf.Range("B65500").End(3).Row
shf.Range("A2:CV" & say1).Sort Key1:=shf.Range("B2")
say2 = shf.Range("B65500").End(3).Row

'shf.PageSetup.PrintArea = "$A$1:$D$" & say2
'MsgBox "Verileriniz proje'ye Aktarıldı..", vbExclamation

End Sub

 

[Orion1]

aşağıdaki satırı ilgili satırla değiştiriniz.

shf.Cells(i + 2, 1 + e) = shf.Cells(i + 2, 1 + e) & " " & Sheets("VG").Cells(i + 5, e).Text

 

[ikikan]

aşağıdaki satırı ilgili satırla değiştiriniz.

shf.Cells(i + 2, 1 + e) = shf.Cells(i + 2, 1 + e) & " " & Sheets("VG").Cells(i + 5, e).Text

Kullandım ama birleştirme yapmıyor bir yerde hatamı yapıyorum?

 

[ikikan]

örnek dosya ektedir

 

[halit3]

Bu kadu denermisiniz.

Sub PROJE()
Dim ss As Integer, say As Integer, say1 As Integer, say2 As Integer
[COLOR=red]Dim i, e, birlestir[/COLOR]
Dim shf As Worksheet
Set shf = Sheets("PROJE")
ss = shf.Range("B65500").End(3).Row
shf.Range("B2:CV" & ss).ClearContents
say = Sheets("HES").ListBox1.ListCount - 5
    For i = 0 To say
        If Sheets("HES").ListBox1.Selected(i) = True Then
 
            [COLOR=red]birlestir = ""[/COLOR]
[COLOR=red]            [/COLOR][COLOR=black]For e = 1 To 50[/COLOR]
[COLOR=red]            If e = 1 Then[/COLOR]
[COLOR=red]            birlestir = Sheets("VG").Cells(i + 5, e).Text[/COLOR]
[COLOR=red]            Else[/COLOR]
[COLOR=red]            birlestir = birlestir & " " & Sheets("VG").Cells(i + 5, e).Text[/COLOR]
[COLOR=red]            End If[/COLOR]
[COLOR=red]            [/COLOR][COLOR=black]Next e[/COLOR]
[COLOR=red]            shf.Cells(i + 2, 1) = birlestir[/COLOR]
 
        End If
    Next i
 
 
say1 = shf.Range("B65500").End(3).Row
shf.Range("A2:CV" & say1).Sort Key1:=shf.Range("B2")
say2 = shf.Range("B65500").End(3).Row
 
'shf.PageSetup.PrintArea = "$A$1:$D$" & say2
'MsgBox "Verileriniz Sayfa2'ye Aktarıldı..", vbExclamation
Call LİSTBOX1
End Sub

 

[ikikan]

Bu kadu denermisiniz.

Sub PROJE()
Dim ss As Integer, say As Integer, say1 As Integer, say2 As Integer
Dim i, e, birlestir
Dim shf As Worksheet
Set shf = Sheets("PROJE")
ss = shf.Range("B65500").End(3).Row
shf.Range("B2:CV" & ss).ClearContents
say = Sheets("HES").ListBox1.[COLOR="Red"]ListCount - 5[/COLOR]
    For i = 0 To say
        If Sheets("HES").ListBox1.Selected(i) = True Then
                
            birlestir = ""
            For e = 1 To 50
            If e = 1 Then
            birlestir = Sheets("VG").Cells(i + 5, e).Text
            Else
            birlestir =[COLOR="Red"] birlestir & " " & Sheets("VG").Cells(i + 5, e).Text[/COLOR]
            End If
            Next e
            shf.Cells(i + 2, 1) = birlestir
        
        End If
    Next i
   
   
say1 = shf.Range("B65500").End(3).Row
shf.Range("A2:CV" & say1).Sort Key1:=shf.Range("B2")
say2 = shf.Range("B65500").End(3).Row
   
'shf.PageSetup.PrintArea = "$A$1:$D$" & say2
'MsgBox "Verileriniz Sayfa2'ye Aktarıldı..", vbExclamation
Call LİSTBOX1
End Sub

Teşekürler Halit Bey bir kaç sorun dışında gayet güzel çalışıyor
1- Sadece satırları bir sütunda birleştiriyor açaba satırları alt alta (chr10) sütünlardaki veriler yanyan A2 hücresinde birleştiremezmiyiz (örnek A2 satırı daki veriler yan yan birleştirip sonra B2 satırı ile alt alta ) bir kaç formül denedim ama sizin kodu bozuyor !
2- ListCount - 5 yaptıgımız için listbox da veriler eksik sayılıyor 18 19 20 kayıtları seçsemde işlem yaptıramadım. ListCount - 5 yapmadan başka bir çözüm varmıdır? yoksa dögülerdemi sorunu çözebiliriz sadece

 

[halit3]

Arkadaşlar aşadaki kod ile seçtigim verileri başka bir sayfaya aktarıyorum lakin bir hücrede birleştirmem gerekli yardım ederseniz sevinirim.

Ben kodunuzun ne iş yaptığını bilmiyorum sadece bir hücrede tapladım aktarmayı yukarıdaki mesajımda eklediğim yerleri kırmızı renk ile belirttim.

şimdide kırmızı yeri ilave yaptım

birlestir = ""
For e = 1 To 50
If e = 1 Then
birlestir = Sheets("VG").Cells(i + 5, e).Text
Else
birlestir = birlestir & [COLOR=red]Chr(10)[/COLOR] & Sheets("VG").Cells(i + 5, e).Text
End If
Next e
shf.Cells(i + 2, 1) = birlestir

 

[ikikan]

Ben kodunuzun ne iş yaptığını bilmiyorum sadece bir hücrede tapladım aktarmayı yukarıdaki mesajımda eklediğim yerleri kırmızı renk ile belirttim.

şimdide kırmızı yeri ilave yaptım

birlestir = ""
For e = 1 To 50
If e = 1 Then
birlestir = Sheets("VG").Cells(i + 5, e).Text
Else
birlestir = birlestir & [COLOR=red]Chr(10)[/COLOR] & Sheets("VG").Cells(i + 5, e).Text
End If
Next e
shf.Cells(i + 2, 1) = birlestir

Halit bey aktarılan sayfadaki (PROJE sayfasındaki ) satırları a1 hücresinde nasıl birleştire biliriz?


bu kod ile çözdüm teşekürler

Sub BirlestirArtik()

Dim hucre As Range

For Each hucre In Sheets("PROJE").Range("B3:B20")
sonuc = sonuc & hucre.Value & Chr(10)
Next hucre

'Selection.ClearContents

Sheets("PROJE").Range("C3").Value = sonuc

End Sub