Sütunlardaki verileri tek satırda birleştirmek

[meleklerim]

İyi günler arkadaşlar, ekte gönderdiğim tablodan da anlaşılacağı gibi sütunlara alt alta işlenen 30 günlük satışların, satırlara aralarına ;@ işaretleri ile tek satırda birleştirmek istiyorum. Günlük satış sayısı sabit olsa basit bir formülle yapmak mümkün ama bazı günler 2 giriş bazı günler 100 giriş olabiliyor.
Yardımınız için şimdiden teşekkürler

Sayfa1
A1 B1 C1 D1
kalem çanta dosya kalem
defter kalem kalem silgi
silgi boya silgi
açkı kitap
boya

Sayfa2
A1 kalem;@defter;@silgi;
A2 çanta;@kalem;@boya;@açkı;
A3 dosya;@kalem;@silgi;@kitap;@boya;
A4 kalem;@silgi;

* günlük satışlar ait oldukları gün satırında ;@ işareti ile birleşecek ama son veride @ olmayacak
* Günlük yapılan satışlar düzensiz sayıda olabilir.

(NOT: Dosya Ekleme Tuşunu Bir Türlü Bulamadım, O Yüzden Böyle Yazmak Zorunda Kaldım)

 

[Vedat Özer]

Merhaba,



Dosya eklemek

 

[meleklerim]

Merhaba,



Dosya eklemek

biliyorum Vedat Bey, daha önce de 1-2 konuya dosya ekleyip gönderdim ancak şimdi bende gelişmiş seçeneklerde dosya ekle yok

 

[YUSUF44]

Aşağıdaki kodları kullanabilirsiniz:

Sub birleştir()
For sat = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    For sut = 2 To Cells(sat, Columns.Count).End(xlToLeft).Column
    Cells(sat, 1) = Cells(sat, 1) & ":@" & Cells(sat, sut)
    Next
Next
End Sub

Foruma dosya eklemek için ya altın üyelik almalısınız ya da dosyanızı dosya ekleme sitelerine ekleyip buraya linkini eklemelisiniz.

 

[YUSUF44]

İsterseniz aşağıdaki kodları da kullanabilirsiniz. Bu kodlar 2 ve daha fazla ürün olması durumunda birleştirmeden sonra eski hücreleri siler:

Sub birleştir1()
For sat = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    For sut = 2 To Cells(sat, Columns.Count).End(xlToLeft).Column
    If sut = 1 Then
    Cells(sat, 1) = Cells(sat, 1)
    Else
    Cells(sat, 1) = Cells(sat, 1) & ":@" & Cells(sat, sut)
    Range(Cells(sat, 2), Cells(sat, sut)).ClearContents
    End If
    Next
Next
End Sub

 

[meleklerim]

Yardımınız için çok teşekkürler ama malesef bu makro işime yaramadı Yusuf Bey,
Bu makroda AYNI SATIRDAKİ farklı hücrelere yazılmış veriler tek satırda birleşiyor.
Halbuki ben AYNI SUTUNDAKİ farklı hücrelere yazılmış verileri tek satırda veri alarında ;@ olacak şekilde birleştirmek istiyorum

 

[bzace]

Merhaba,
Alternat olarak KTF'li

Function Sütun_birleştir(ByVal cell_range As Range, _
                    Optional ByVal seperator As String) As String
'http://stackoverflow.com/questions/15888353/concatenate-multiple-ranges-using-vba
Dim cell As Range
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long

cellArray = cell_range.Value

For i = 1 To UBound(cellArray, 1)
    For j = 1 To UBound(cellArray, 2)
        If Len(cellArray(i, j)) <> 0 Then
            newString = newString & (seperator & cellArray(i, j))
        End If
    Next
Next

If Len(newString) <> 0 Then
    newString = Right$(newString, (Len(newString) - Len(seperator)))
End If

Sütun_birleştir = newString

End Function

Kullanılışı: =Sütun_birleştir(A1:A100;";@")



Bir sütundaki dolu olan hücreleri Bir hücrede aralara virgül koyarak birleştirmek

 

[meleklerim]

KTF konusunu hiç bilmiyorum, sanırım excele "formül ekleme" durumu var, nasıl ekleyeceğim?
teşekkürler

 

[YUSUF44]

Pardon olayı yanlış anlamışım aşağıdaki kodları kullanabilirsiniz:

Sub birleştir2()
For sut = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
    For sat = 2 To Cells(Rows.Count, sut).End(xlUp).Row
    If sat = 1 Then
    Cells(1, sut) = Cells(1, sut)
    Else
    Cells(1, sut) = Cells(1, sut) & ":@" & Cells(sat, sut)
    Range(Cells(2, sut), Cells(sat, sut)).ClearContents
    End If
    Next
Next
End Sub

 

[meleklerim]

sutün_birleştir komutunu eklemeyi çözdüm, teşekkürler sayenizde birşey daha öğrenmiş olduk. Verdiğiniz kodu yazdıktan sonra;
=sütun_birleştir(A2:A100;";@") formülü benim işimi görüyor AMA konuda da belirttiğim gibi herzaman A2:A100 arası verilerle dolu olmuyor. Şimdiki formülde eğer bir sonraki hücrede veri yoksa birleştirmeyi kesmesi gerekiyor yoksa örneğin A2 ve A3 hücrelerinde veri varsa birleştirilen satırda 98 tane ;@ işareti çıkıyor.

 

[meleklerim]

Pardon olayı yanlış anlamışım aşağıdaki kodları kullanabilirsiniz:

Sub birleştir2()
[COLOR="Red"]For sut [/COLOR]= 1 To Cells(1, Columns.Count).End(xlToLeft).Column
    For sat = 2 To Cells(Rows.Count, sut).End(xlUp).Row
    If sat = 1 Then
    Cells(1, sut) = Cells(1, sut)
    Else
    Cells(1, sut) = Cells(1, sut) & ":@" & Cells(sat, sut)
    Range(Cells(2, sut), Cells(sat, sut)).ClearContents
    End If
    Next
Next
End Sub

hata veriyor Yusuf Bey, Hatalı yeri kırmızı renkle belirttim.

 

[bzace]

#7 numaralı mesajdaki Kodu tekrar deneyiniz.KTF istemiyorsanız Yusuf Bey'in önerisini kullanınız.

 

[YUSUF44]

Ben denedim hata vermedi.

 

[meleklerim]

Ben denedim hata vermedi.

çok teşekkürler Yusuf Bey, siz ve bzace üyenin yardımlarıyla istediğim formüle ulaştım.

 

[sedatimben]

merhaba
9 nolu formülü nasıl bütün sayfalar için kullanabiliriz.

yani butonun olduğu sayfa değilde bütün sayfalarda aynı birşeltirmeyi yapabilsek

 

[YUSUF44]

Ya her sayfaya düğme ekleyip makro atamalısınız ya da makroya yeni bir döngü eklenip sayfalara göre çalışması sağlanabilir. Bunun için örnek bir dosyayla sorunuzu sorarsanız daha iyi olur.

 

[sedatimben]

yusuf bey kodu bulduğum bir kod ekleyerek tüm sayfalara uygulanmasını sağladım
yardımın için teşekkürler

Sub birleştir2()
For Each sf In Worksheets
sf.Select
For sut = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For sat = 2 To Cells(Rows.Count, sut).End(xlUp).Row
If sat = 1 Then
Cells(1, sut) = Cells(1, sut)
Else
Cells(1, sut) = Cells(1, sut) & "," & Cells(sat, sut)
Range(Cells(2, sut), Cells(sat, sut)).ClearContents
End If
Next
Next
Next
End Sub

 

[Erdem Akdemir]

Alternatif,

Birleştirme imlecini kendiniz belirleyebiliyorsunuz.

Function birles(hucre As Range, Optional imlec As String = "") As String

For Each alan In hucre

k = k & alan & imlec

Next alan

If imlec = "" Then
birles = k
Else
birles = VBA.Left(k, VBA.Len(k) - 1)
End If
End Function

=birles(a1:10;"@")