• DİKKAT

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

Aynı satırdaki verilere ait bilgileri birleştirme

Katılım
18 Ağustos 2017
Mesajlar
119
Excel Vers. ve Dili
excel.2013
Arkadaşlar merhaba ,

Bir konuda desteğe ihtiyacım var data sayfamda iller ve ürünler adlı iki satırım var il isimleri ve karşılarında ürün isimleri bulunuyor yapmak isteğim örneğin bir ile ait ürünleri başka bir sayfada birleştirmek istiyorum . Data kalabalık olacağı için tek tek yapmak çok vakit kaybı olacak . daha kısa bir yolu var mıdır. Değerli yardımlarınızı rica ederim . Örnek dosyamı ekledim
Teşekkürler
 

Ekli dosyalar

Aşağıdaki kodu boş bir module içine ekleyip çalıştırabilirsiniz.
C++:
Sub Birleştir()
   Dim Arr, Dict As Object, Liste(), Sh1 As Worksheet, Sh2 As Worksheet
   Set Sh1 = Worksheets("data")
   Set Sh2 = Worksheets("birleştirme")
   Set Dict = CreateObject("Scripting.Dictionary")
   Arr = Sh1.Range("A1").CurrentRegion.Value
   If UBound(Arr) < 2 Then Exit Sub
   ReDim Liste(1 To UBound(Arr), 1 To 2)
  
   For i = 2 To UBound(Arr)
      If Not Dict.Exists(Arr(i, 1)) Then
         Say = Say + 1
         Dict.Add Arr(i, 1), Say
         Liste(Say, 1) = Arr(i, 1)
         Liste(Say, 2) = Arr(i, 2)
      Else
         Liste(Dict(Arr(i, 1)), 2) = Liste(Dict(Arr(i, 1)), 2) & " ; " & Arr(i, 2)
      End If
   Next i
   Sh2.Range("A2:B" & Rows.Count).ClearContents
   Sh2.Range("A2").Resize(Say, 2) = Liste
End Sub
 
Aşağıdaki kodu boş bir module içine ekleyip çalıştırabilirsiniz.
C++:
Sub Birleştir()
   Dim Arr, Dict As Object, Liste(), Sh1 As Worksheet, Sh2 As Worksheet
   Set Sh1 = Worksheets("data")
   Set Sh2 = Worksheets("birleştirme")
   Set Dict = CreateObject("Scripting.Dictionary")
   Arr = Sh1.Range("A1").CurrentRegion.Value
   If UBound(Arr) < 2 Then Exit Sub
   ReDim Liste(1 To UBound(Arr), 1 To 2)
 
   For i = 2 To UBound(Arr)
      If Not Dict.Exists(Arr(i, 1)) Then
         Say = Say + 1
         Dict.Add Arr(i, 1), Say
         Liste(Say, 1) = Arr(i, 1)
         Liste(Say, 2) = Arr(i, 2)
      Else
         Liste(Dict(Arr(i, 1)), 2) = Liste(Dict(Arr(i, 1)), 2) & " ; " & Arr(i, 2)
      End If
   Next i
   Sh2.Range("A2:B" & Rows.Count).ClearContents
   Sh2.Range("A2").Resize(Say, 2) = Liste
End Sub

teşekkürler emeğinize sağlık
 
Geri
Üst