• DİKKAT

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

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

  • Konbuyu başlatan Konbuyu başlatan muratot
  • Başlangıç tarihi Başlangıç tarihi
Korhan Ayhan' Alıntı:
Yeni dosyanız içinde aşağıdaki kodu deneyiniz.

C++: 
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
Genişletmek için tıkla ...
Korhan Bey, Tam istediğim gibi olmuş ellerinize sağlık...
 
Korhan Ayhan' Alıntı:
Yeni dosyanız içinde aşağıdaki kodu deneyiniz.

C++: 
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
Genişletmek için tıkla ...
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
 
Merhaba

Üstteki ve soldaki adlar bölümünü siz mi dolduracaksınız? Yoksa makro otomatik listede ne varsa listeleyecek mi?
 
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
 
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...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst