Aynı satırdaki verilere ait bilgileri birleştirme

[sldrkyurdal]

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

 

[TiOr]

Slm,
Pivot işinizi görmez mi?

 

[sldrkyurdal]

Slm,
Pivot işinizi görmez mi?


Ekli dosyayı görüntüle 237249

merhaba , evet bu şekilde yapmak da bir yöntem ancak aynı satırda birleşmesi benim için önemli teşekkürler

 

[ÖmerFaruk]

Aşağıdaki kodu boş bir module içine ekleyip çalıştırabilirsiniz.

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

 

[sldrkyurdal]

Aşağıdaki kodu boş bir module içine ekleyip çalıştırabilirsiniz.

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