Excelde hücreleri koşula göre virgül ile birleştirme

[irfnctnky]

Resimdeki örneği formül ile nasıl yapabilirim yardımcı olabilecek var mı?

Ys3n0d.png

Ys3n0d Fotoğrafı, resimleri, fotoğrafları

hizliresim.com

 

[Korhan Ayhan]

Kullandığınız sürüme göre birleştirme işlemini makro ile yapabilirsiniz.

Forumda K_BİRLEŞTİR ya da KBİRLEŞTİR ifadesi ile arama yapınız.

 

[yanginci34]

örnek dosyayı incelermisiniz.

Bilgi

Bilgi

dosyam.org

 

[irfnctnky]

örnek dosyayı incelermisiniz.

Bilgi

Bilgi

dosyam.org

işe yaradı teşekkürler ama birden fazla sayfada kullanamıyorum bunun hakkında yardımcı olabilir misiniz

 

[excelokyanus500]

Deneyin

Sub Birlestir()

     On Error Resume Next
     Application.ScreenUpdating = False
     For Each Syf In ActiveWorkbook.Sheets
     Syf.Select
     Set Alan = Syf.Range("A1:B10") 'Birlestirilecek alan
     Set Dic = CreateObject("Scripting.Dictionary")
     Hucre = Alan.Value
     For i = 1 To UBound(Hucre, 1)
      Bulunan = Hucre(i, 1)
      If Dic.Exists(Bulunan) Then
      Dic(Hucre(i, 1)) = Dic(Hucre(i, 1)) & "," & Hucre(i, 2)
    Else
        Dic(Hucre(i, 1)) = Hucre(i, 2)
    End If
   Next
      Syf.Range("e1").Value = "KOD"
      Syf.Range("f1").Value = "BOX"
      Alan.Range("e2").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys) ' Birleşenlerin gösterileceği alan
      Alan.Range("f2").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
      Range("E1:F1").Font.Bold = True
      Range("E1:F1").Font.Color = -16776961
      Range(Range("E1"), Range("E1").SpecialCells(xlLastCell)).Select
    
      With Selection.Borders
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
      End With
      Syf.Range("e1").Select
   Next Syf
    
   Application.ScreenUpdating = True

End Sub

 

[irfnctnky]

Deneyin

Sub Birlestir()

     On Error Resume Next
     Application.ScreenUpdating = False
     For Each Syf In ActiveWorkbook.Sheets
     Syf.Select
     Set Alan = Syf.Range("A1:B10") 'Birlestirilecek alan
     Set Dic = CreateObject("Scripting.Dictionary")
     Hucre = Alan.Value
     For i = 1 To UBound(Hucre, 1)
      Bulunan = Hucre(i, 1)
      If Dic.Exists(Bulunan) Then
      Dic(Hucre(i, 1)) = Dic(Hucre(i, 1)) & "," & Hucre(i, 2)
    Else
        Dic(Hucre(i, 1)) = Hucre(i, 2)
    End If
   Next
      Syf.Range("e1").Value = "KOD"
      Syf.Range("f1").Value = "BOX"
      Alan.Range("e2").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys) ' Birleşenlerin gösterileceği alan
      Alan.Range("f2").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
      Range("E1:F1").Font.Bold = True
      Range("E1:F1").Font.Color = -16776961
      Range(Range("E1"), Range("E1").SpecialCells(xlLastCell)).Select
   
      With Selection.Borders
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
      End With
      Syf.Range("e1").Select
   Next Syf
   
   Application.ScreenUpdating = True

End Sub

İstediğim sonuca ulaşamadım maalesef 3 haneli rakamlarda sıkıntı yaratıyor.

 

[excelokyanus500]

Ayraç olan virgülü "-" yaparsanız sorun ortadan kalkacaktır. Veya & " ," & bunu kopyalayıp ilgili yere yapştırırsanız.

 

[dogankostu]

örnek dosyayı incelermisiniz.

Bilgi

Bilgi

dosyam.org

Merhaba
dosyanızı denedim oldu fakat birleştirince linkler kayboluyor. Yardımcı olabilir misiniz?