Ara bul birleştir yaz

[mhrcvk]

Merhaba arkadaşlar,

Ekteki dosyada 1 ci sayfada mükerrer tcler var 2. sayfada tekil hale getirdim c sütününa 1.sayfada aynı tcden 2 tane veya 3 tane varsa gsm numaralarını birleştirip yazmasını istiyorum.

 

[Ömer]

Merhaba,

Bu işlem için fonksiyon kullanmak oldukça fazla yardımcı sütun kullanmanıza neden olur.
Bu yüzden bu tür uygulamaları makro ile çözmenizde fayda var.

Sub Birlestir()
 
    Dim d As Object, i As Long, s, deg, S1 As Worksheet
 
    Set S1 = Sheets("1")
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("2").Select

    For i = 2 To S1.Cells(Rows.Count, "B").End(xlUp).Row
        deg = S1.Cells(i, "B")
        If Not d.exists(deg) Then
            s = S1.Cells(i, "C")
            d.Add deg, s
        Else
            s = d.Item(deg)
            s = s & "--" & S1.Cells(i, "C")
            d.Item(deg) = s
        End If
    Next i
    
    Range("A2:C" & Rows.Count).ClearContents
    Range("A2") = 1
    Range("A2:A" & d.Count + 1).DataSeries Rowcol:=xlColumns, _
        Type:=xlLinear, Date:=xlDay, Step:=1
    Range("B2").Resize(d.Count, 2) = _
        Application.Transpose(Array(d.keys, d.items))
        
    Application.ScreenUpdating = True

End Sub

.

 

[igultekin2000]

makroda düzenleme

güzel bir çalışma, ancak telefon numaralarını yan yana birleştirmek yerine yan yana sütunlara adapte edebilsek benim için çok daha kullanışlı olacak. teşekkürler.

 

[mhrcvk]

Ömer Bey,

Çok teşekkür ederim sağolun. Ama ana listeme aldığımda RUN TİME error '13' type mismatch hatası alıyorum anlamadım.

 

[mhrcvk]

Ömer Bey,

Çok teşekkür ederim sağolun. Ama ana listeme aldığımda RUN TİME error '13' type mismatch hatası alıyorum anlamadım.

yardımcı olabilecek var mı ?

 

[Ömer]

güzel bir çalışma, ancak telefon numaralarını yan yana birleştirmek yerine yan yana sütunlara adapte edebilsek benim için çok daha kullanışlı olacak. teşekkürler.

Bu şekilde deneyin.

Sub Birlestir()
 
    Dim d As Object, i As Long, s, deg, S1 As Worksheet
    Dim a1, a2, t, j As Integer, sat As Long, sut As Integer
 
    Set S1 = Sheets("1")
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("2").Select

    For i = 2 To S1.Cells(Rows.Count, "B").End(xlUp).Row
        deg = S1.Cells(i, "B")
        If Not d.exists(deg) Then
            s = S1.Cells(i, "C")
            d.Add deg, s
        Else
            s = d.Item(deg)
            s = s & "|" & S1.Cells(i, "C")
            d.Item(deg) = s
        End If
    Next i
    
    Range(Cells(2, "A"), Cells(Rows.Count, Columns.Count)).ClearContents
    
    a1 = d.keys: a2 = d.items: sat = 2
    For i = 0 To d.Count - 1
        Cells(sat, "A") = i + 1
        Cells(sat, "B") = a1(i)
        sut = 3
        t = Split(a2(i), "|")
        For j = 0 To UBound(t)
            Cells(sat, sut) = t(j)
            sut = sut + 1
        Next j
        sat = sat + 1
    Next i
        
    Application.ScreenUpdating = True

End Sub

.

 

[Ömer]

Ömer Bey,

Çok teşekkür ederim sağolun. Ama ana listeme aldığımda RUN TİME error '13' type mismatch hatası alıyorum anlamadım.

Örnek dosyanızdaki sayfa isimleri ile, uyguladığınız dosyadaki sayfa isimleri aynı mı.

Hata aldığınız dosyayı ekler misiniz.

.

 

[mhrcvk]

Örnek dosyanızdaki sayfa isimleri ile, uyguladığınız dosyadaki sayfa isimleri aynı mı.

Hata aldığınız dosyayı ekler misiniz.

.

Ömer Bey,

Ana listeyi yükledim tcden ayrıma gidere bilgi kısumlarını ve gsm kısımlarını birer hücrede arada "-" ile ayırarar bir hücreye yazmak istiyorum.

http://www.dosyaupload.com/8R63

 

[igultekin2000]

Teşekkürler, sorunsuz çalışıyor.

 

[Ömer]

Ömer Bey,

Ana listeyi yükledim tcden ayrıma gidere bilgi kısumlarını ve gsm kısımlarını birer hücrede arada "-" ile ayırarar bir hücreye yazmak istiyorum.

http://www.dosyaupload.com/8R63

Bu şekilde deneyin.

Sub Birlestir()
 
    Dim d As Object, i As Long, s, deg, S1 As Worksheet, a1, a2
 
    Set S1 = Sheets("sayfa2") 'verilerin alınacağı sayfa adı
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select 'verilerin yazılacağı sayfa adı

    For i = 2 To S1.Cells(Rows.Count, "B").End(xlUp).Row
        deg = S1.Cells(i, "E")
        If Not d.exists(deg) Then
            s = Array(S1.Cells(i, "C"), S1.Cells(i, "F"))
            d.Add deg, s
        Else
            s = d.Item(deg)
            s(0) = s(0) & "-" & S1.Cells(i, "C")
            s(1) = s(1) & "-" & S1.Cells(i, "F")
            d.Item(deg) = s
        End If
    Next i
    
    Range("A2:D" & Rows.Count).ClearContents

    a1 = d.keys: a2 = d.items
    For i = 0 To d.Count - 1
        s = a2(i)
        Cells(i + 2, "A") = i + 1
        Cells(i + 2, "B") = a1(i)
        Cells(i + 2, "C") = s(0)
        Cells(i + 2, "D") = s(1)
    Next i
        
    Application.ScreenUpdating = True

End Sub

.

 

[Hexafluramon]

düşey ara ile

"mhrcvk" hocam bende şöyle formülle bir şeyler yapmaya çalıştım. Tabi basit oldu ama. Ömer hocamın ki gibi profesyonel olmadı. İsterseniz bir göz atarsınız. Telefonlar ayrı sütunlarda olsun dediğiniz için böyle bir şey yaptım. Son sütunda birleştirilmiş hali var. Ama ordaki fazla "-" ler için biraz uğraşmak gerekir "eğer" ile.

 

[mhrcvk]

"mhrcvk" hocam bende şöyle formülle bir şeyler yapmaya çalıştım. Tabi basit oldu ama. Ömer hocamın ki gibi profesyonel olmadı. İsterseniz bir göz atarsınız. Telefonlar ayrı sütunlarda olsun dediğiniz için böyle bir şey yaptım. Son sütunda birleştirilmiş hali var. Ama ordaki fazla "-" ler için biraz uğraşmak gerekir "eğer" ile.

ilginiz için çok teşekkür ederim fakat istediğim işlem ana listemde exel de bir satırın alabileceğin karakter sayısını aşmasından ötürü olmuyormuş maalesef çözümü bu durum da olmuyor.