Farklı sütunlardaki verilerin tek bir sütunda sıralanması

[sahika51]

Arkadaşlar iyi günler. Bir tablm var. c2:f32 içerisindeki isiölerin H2 sütunundanitibaren her isimden yalnız 1 tane kullanmak kaydıyla listelnmesi gerekiyor. İnanın çok baktum bulamadım. yardımcı olursanız sevinirimç

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Sub kod()
Dim s As Object
Dim hcr As Range
Set s = CreateObject("Scripting.Dictionary")
For Each hcr In Range("C2:F32")
    For Each h In Split(hcr.Value, ", ")
        If Not s.Exists(h) Then s.Add h, 1 Else s(h) = s(h) + 1
    Next
Next
Range("H2").Resize(s.Count, 1).Value = Application.Transpose(s.Keys())
Range("I2").Resize(s.Count, 1).Value = Application.Transpose(s.Items())
End Sub

 

[muhasebeciyiz]

Eğer ihtiyacınız benzersiz değerleri listelemek ve görünüm sayılarını da takip etmekse, Ömerbey'in kodu daha uygundur.
Eğer sadece benzersiz değerleri listelemekse, benim verdiğim kod yeterli olur.

 

[sahika51]

Teşekkür ederim

 

[enginktk]

Merhaba,
Deneyiniz...

Sub kod()
Dim s As Object
Dim hcr As Range
Set s = CreateObject("Scripting.Dictionary")
For Each hcr In Range("C2:F32")
    For Each h In Split(hcr.Value, ", ")
        If Not s.Exists(h) Then s.Add h, 1 Else s(h) = s(h) + 1
    Next
Next
Range("H2").Resize(s.Count, 1).Value = Application.Transpose(s.Keys())
Range("I2").Resize(s.Count, 1).Value = Application.Transpose(s.Items())
End Sub

Merhaba Ömer bey,
Yazmış olduğunuz makroda seçili hücreler olan "(C2:F32)" yerine sayfada yazılı olan bütün alanları otomatik seçim nasıl yaptıra biliriz?

Örneğin benim şu anki dosyamda (a1: Eu7) her dosyamda sütun sayısı farklı olacağı için otomatik seçim nasıl yaptırabilirz?

 

[volki_112]

Merhaba Ömer bey,
Yazmış olduğunuz makroda seçili hücreler olan "(C2:F32)" yerine sayfada yazılı olan bütün alanları otomatik seçim nasıl yaptıra biliriz?

Örneğin benim şu anki dosyamda (a1: Eu7) her dosyamda sütun sayısı farklı olacağı için otomatik seçim nasıl yaptırabilirz?

Aşağıdaki kodu kullanınız. Seçilmek istenen aralıkları ve nereye veri yazılacağını size soruyor.

Sub Kod()
    Dim s As Object
    Dim dataRange As Range, outputCell As Range
    Dim hcr As Range
    Dim cellValue As String
    Dim hArray As Variant
    Dim i As Long
    Dim h As String
    
    ' Kullanıcıdan veri aralığını seçmesini iste
    On Error Resume Next
    Set dataRange = Application.InputBox("Veri aralığınızı seçiniz. İsterseniz mouse ile seçim yapabilirsiniz ya da elle (örn: C2:F25) yazabilirsiniz. ", "Aralık Seçimi", Type:=8)
    If dataRange Is Nothing Then Exit Sub
    On Error GoTo 0
    
    ' Kullanıcıdan sonuçların yazılacağı başlangıç hücresini seçmesini iste
    On Error Resume Next
    Set outputCell = Application.InputBox("Sonuçların yazılacağı başlangıç hücresini seçiiz. İsterseniz mouse ile seçebilirsiniz ya da elle (örn: H2) yazabilirsiniz.", "Hücre Seçimi", Type:=8)
    If outputCell Is Nothing Then Exit Sub
    On Error GoTo 0
    
    ' Sözlük nesnesini oluştur
    Set s = CreateObject("Scripting.Dictionary")
    
    ' Veri aralığını döngüyle işleme
    For Each hcr In dataRange
        cellValue = hcr.Value ' Hücredeki değeri al
        hArray = Split(cellValue, ", ") ' Hücredeki değeri virgülle ayır
        For i = LBound(hArray) To UBound(hArray)
            h = Trim(hArray(i)) ' Dizedeki öğeyi al ve boşlukları temizle
            If Not s.Exists(h) Then
                s.Add h, 1
            Else
                s(h) = s(h) + 1
            End If
        Next i
    Next hcr
    
    ' Sonuçları yazdır
    outputCell.Resize(s.Count, 1).Value = Application.Transpose(s.Keys())
    outputCell.Offset(0, 1).Resize(s.Count, 1).Value = Application.Transpose(s.Items())
    
    MsgBox "İşlem tamamlandı!", vbInformation
End Sub

 

[enginktk]

@volki_112 çok teşekkür ederim ama şu şekilde bir sıkıntı oldu.
Benim Tablom A1 Hücresinden EU7 hücresine kadar bu alan içerisinde A sütununda ki 7 satırı alt alta yazması sonra B sütunundaki 7 satırı alt alta yazması bu şekilde EU hücresine kadar bütün alanları alt alta kopyalaması. Yardımcı olursanız çok sevinirim.

 

[volki_112]

Musait olunca bakayim. Kodlari yapay zekaya yazdirdim.

 

[ÖmerBey]

Benim Tablom A1 Hücresinden EU7 hücresine kadar bu alan içerisinde A sütununda ki 7 satırı alt alta yazması sonra B sütunundaki 7 satırı alt alta yazması bu şekilde EU hücresine kadar bütün alanları alt alta kopyalaması. Yardımcı olursanız çok sevinirim.

Merhaba,
Dosya yapısı farklı olduğu için yazılacak kod da değişecektir. Örnek bir dosya paylaşıp isteğinizi dosya üzerinde gösterirseniz isteğinize uygun kod yazılabilir.