• DİKKAT

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

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

I

irfnctnky

Katılım
23 Mart 2021
Mesajlar
3
Excel Vers. ve Dili
microsoft office ev ve iş 2019
Resimdeki örneği formül ile nasıl yapabilirim yardımcı olabilecek var mı?


Ys3n0d.png

Ys3n0d Fotoğrafı, resimleri, fotoğrafları
hizliresim.com hizliresim.com
 
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.
 
Deneyin


Kod: 
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
 
excelokyanus500' Alıntı:
Deneyin


Kod: 
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
Genişletmek için tıkla ...
İstediğim sonuca ulaşamadım maalesef 3 haneli rakamlarda sıkıntı yaratıyor.
 
Ayraç olan virgülü "-" yaparsanız sorun ortadan kalkacaktır. Veya & " ," & bunu kopyalayıp ilgili yere yapştırırsanız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst