Macro ile tek hücrede yazılı adları yan hücrelere sıralama

[muratot]

Yeni dosyanız içinde aşağıdaki kodu deneyiniz.

Option Explicit

Sub Sembol_Say()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Veri As Variant, Son As Long, X As Long, Y As Integer
    Dim Metin As Variant, Say As Long, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("İLK HALİ")
    Set S2 = Sheets("OLMASINI İSTEDİĞİM")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    S2.Range("A2:B" & S2.Rows.Count).Clear
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
   
    Veri = S1.Range("C2:C" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 2)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Metin = Split(Veri(X, 1), "," & Chr$(160))
        For Y = LBound(Metin) To UBound(Metin)
            If Not Dizi.Exists(Metin(Y)) Then
                Say = Say + 1
                Dizi.Add Metin(Y), Say
                Liste(Say, 1) = Metin(Y)
                Liste(Say, 2) = 1
            Else
                Liste(Dizi.Item(Metin(Y)), 2) = Liste(Dizi.Item(Metin(Y)), 2) + 1
            End If
        Next
    Next
   
    S2.Range("A2").Resize(Say, 2) = Liste
    S2.Range("A2").Resize(Say, 2).Borders.LineStyle = 1
    S2.Range("A2:B" & S2.Rows.Count).Sort S2.Range("B2"), xlDescending, , , , , , xlNo
    S2.Columns.AutoFit
    S2.Select
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Korhan Bey, Tam istediğim gibi olmuş ellerinize sağlık...

 

[muratot]

Yeni dosyanız içinde aşağıdaki kodu deneyiniz.

Option Explicit

Sub Sembol_Say()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Veri As Variant, Son As Long, X As Long, Y As Integer
    Dim Metin As Variant, Say As Long, Zaman As Double
  
    Zaman = Timer
  
    Set S1 = Sheets("İLK HALİ")
    Set S2 = Sheets("OLMASINI İSTEDİĞİM")
    Set Dizi = CreateObject("Scripting.Dictionary")
  
    S2.Range("A2:B" & S2.Rows.Count).Clear
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
  
    Veri = S1.Range("C2:C" & Son).Value
  
    ReDim Liste(1 To Son, 1 To 2)
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Metin = Split(Veri(X, 1), "," & Chr$(160))
        For Y = LBound(Metin) To UBound(Metin)
            If Not Dizi.Exists(Metin(Y)) Then
                Say = Say + 1
                Dizi.Add Metin(Y), Say
                Liste(Say, 1) = Metin(Y)
                Liste(Say, 2) = 1
            Else
                Liste(Dizi.Item(Metin(Y)), 2) = Liste(Dizi.Item(Metin(Y)), 2) + 1
            End If
        Next
    Next
  
    S2.Range("A2").Resize(Say, 2) = Liste
    S2.Range("A2").Resize(Say, 2).Borders.LineStyle = 1
    S2.Range("A2:B" & S2.Rows.Count).Sort S2.Range("B2"), xlDescending, , , , , , xlNo
    S2.Columns.AutoFit
    S2.Select
  
    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Korhan Bey, Son gönderdiğiniz macro harika çok teşekkür ederim. Yukarıdaki Excel e "İSTATİSTİK" adlı bir sayfa daha açsam orayada aşağıdaki linkte belirttiğim gibi bir düzzenleme yapılabilir mi? (Üstteki ve Soldaki adlar sürekli değişiklik göstermektedir)

İndir Adsız

Dosyayı indir Adsız

dosya.co

 

[Korhan Ayhan]

Merhaba

Üstteki ve soldaki adlar bölümünü siz mi dolduracaksınız? Yoksa makro otomatik listede ne varsa listeleyecek mi?

 

[muratot]

Merhaba

Üstteki ve soldaki adlar bölümünü siz mi dolduracaksınız? Yoksa makro otomatik listede ne varsa listeleyecek mi?

Korhan Bey, İlk Hali adlı sayfadaki verilere göre macronun yapmasını istiyorum.

 

[Korhan Ayhan]

Deneyiniz.

Harici Link (Silinebilir) ; https://s2.dosya.tc/server14/xigsp1/18.01_alarmgunlugu.xlsm.html

 

[muratot]

Deneyiniz.

Harici Link (Silinebilir) ; https://s2.dosya.tc/server14/xigsp1/18.01_alarmgunlugu.xlsm.html

Korlah Bey, Süper Ötesi olmuş ellerinize sağlık

 

[muratot]

Merhaba Korhan Bey, Önceki yaptığınız macroları sorunsuz kullanıyorum. Mümkün ise bir isteğim daha olacak. Birde ayrı bir sayfada saate göre kaç kez geldiğini pivotlama şansımız olabilirmi?
Ben sayfayı açtım şablonu hazırladım. Şimdiden teşekkürler...

İndir ALARMGÜNLÜĞÜ1

Dosyayı indir ALARMGÜNLÜĞÜ1

dosya.co

 

[muratot]

Merhaba Korhan Bey, Olma ihtimali var mı?

 

[muratot]

Merhabalar, Dosyanın son işlemlerini Korhan Bey, yaptığı için mesajımı Korhan Bey olarak atmıştım. Bilgisi olan diğer Yönetici arkadaşlarda bakabilir ise çok sevinirim...

 

[muratot]

Merhabalar, Güncel...

 

[Korhan Ayhan]

Deneyiniz.

Harici Link (Silinebilir) ; https://dosyam.org/Y41/ALARMGÜNLÜĞÜ1.xlsm

 

[muratot]

Deneyiniz.

Harici Link (Silinebilir) ; https://dosyam.org/Y41/ALARMGÜNLÜĞÜ1.xlsm

Çok Teşekkür ederim Korhan Bey