• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Ara bul birleştir yaz

  • Konbuyu başlatan Konbuyu başlatan mhrcvk
  • Başlangıç tarihi Başlangıç tarihi
M

mhrcvk

Katılım
18 Ekim 2012
Mesajlar
126
Excel Vers. ve Dili
2016 türkçe
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.
 

Ekli dosyalar

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.

Kod: 
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

.
 
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.
 
Ö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.
 
Son düzenleme:
igultekin2000' Alıntı:
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.
Genişletmek için tıkla ...

Bu şekilde deneyin.

Kod: 
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

.
 
mhrcvk' Alıntı:
Ö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.
Genişletmek için tıkla ...

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

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

.
 
mhrcvk' Alıntı:
Ö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
Genişletmek için tıkla ...

Bu şekilde deneyin.

Kod: 
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

.
 
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.
 

Ekli dosyalar

Hexafluramon' Alıntı:
"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.
Genişletmek için tıkla ...

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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst