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

muratot · 18 Ocak 2021

Merhabalar,
Elimde 1.000 satırlık bir excel var C hücresinde "AYGAZ, GEDZA, KERVN, INVEO, KRONT, MERIT, PKENT, RODRG, SODSN, OYAYO, YESIL, AGYO, BAYRK, DURDO, MAALT" bu şekilde tanımlar bulunuyor ben bunları yan sütunlara sadece örnek "AYGAZ" bu şekilde gelmesini istiyorum bir türlü beceremedim. Yardımcı olabilirmisiniz?

İndir Kitap1

Dosyayı indir Kitap1

dosya.co

Muzaffer Ali · 18 Ocak 2021

Merhaba.

"İLKHALİ" adlı sayfanın kod kısmına aşağıdaki kodları kopyalayın ve çalıştırın.

Kod:

Sub Test()
    Dim Bak As Integer
    Dim Semboller
    Dim BakS As Integer
    For Bak = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        Semboller = Split(Cells(Bak, "C"), ",")
        For BakS = 0 To UBound(Semboller)
            Cells(Bak, 4 + BakS) = Semboller(BakS)
        Next
    Next
End Sub

muratot · 18 Ocak 2021

Muzaffer Ali' Alıntı:
Merhaba.

"İLKHALİ" adlı sayfanın kod kısmına aşağıdaki kodları kopyalayın ve çalıştırın.

Kod:

Sub Test() Dim Bak As Integer Dim Semboller Dim BakS As Integer For Bak = 2 To Cells(Rows.Count, "C").End(xlUp).Row Semboller = Split(Cells(Bak, "C"), ",") For BakS = 0 To UBound(Semboller) Cells(Bak, 4 + BakS) = Semboller(BakS) Next Next End Sub

Muzaffer Bey, İlginiz için teşekkür ederim. C hücresinde gelenleri dediğim gibi satır satır ayırıyor. ancak 2. hücreye ayrılanları boşluk " PRKAB" sonrasında ad getiriyor. boşlukların gelmesi engellenebilir mi?

Korhan Ayhan · 18 Ocak 2021

Deneyiniz.

30 sütuna metni bölecek şekilde kurguladım. Daha fazla sembol içeren hücreniz varsa revize etmek gerekir.

C++:

Option Explicit

Sub Metni_Sutunlara_Bol()
    Dim S1 As Worksheet, Veri As Variant, Son As Long, X As Long
    Dim Metin As Variant, Y As Integer, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("İLK HALİ")
   
    S1.Range("D:AG").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 30)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Metin = Split(Veri(X, 1), "," & Chr$(160))
        For Y = LBound(Metin, 1) To UBound(Metin, 1)
            Liste(X, Y + 1) = Metin(Y)
        Next
    Next
   
    S1.Range("D2").Resize(Son, UBound(Liste, 2)) = Liste
    S1.Columns.AutoFit
   
    Set S1 = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Muzaffer Ali · 18 Ocak 2021

muratot' Alıntı:
Muzaffer Bey, İlginiz için teşekkür ederim. C hücresinde gelenleri dediğim gibi satır satır ayırıyor. ancak 2. hücreye ayrılanları boşluk " PRKAB" sonrasında ad getiriyor. boşlukların gelmesi engellenebilir mi?

O zaman aşağıdaki kodları kullanın.

Kod:

Sub Test()
    Dim Bak As Integer
    Dim Semboller
    Dim BakS As Integer
    For Bak = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        Semboller = Split(Cells(Bak, "C"), ",")
        For BakS = 0 To UBound(Semboller)
            Cells(Bak, 4 + BakS) = WorksheetFunction.Substitute(Semboller(BakS), " ", "")
        Next
    Next
End Sub

muratot · 18 Ocak 2021

Muzaffer Ali' Alıntı:

O zaman aşağıdaki kodları kullanın.

Kod:

Sub Test()
    Dim Bak As Integer
    Dim Semboller
    Dim BakS As Integer
    For Bak = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        Semboller = Split(Cells(Bak, "C"), ",")
        For BakS = 0 To UBound(Semboller)
            Cells(Bak, 4 + BakS) = WorksheetFunction.Substitute(Semboller(BakS), " ", "")
        Next
    Next
End Sub

Muzaffer Bey, ilk ayırdığı sütun sorunsuz (boşluk yok) sonraki adlarda boşluk bırakmaya devam ediyor.

muratot · 18 Ocak 2021

Korhan Ayhan' Alıntı:

Deneyiniz.

30 sütuna metni bölecek şekilde kurguladım. Daha fazla sembol içeren hücreniz varsa revize etmek gerekir.

C++:

Option Explicit

Sub Metni_Sutunlara_Bol()
    Dim S1 As Worksheet, Veri As Variant, Son As Long, X As Long
    Dim Metin As Variant, Y As Integer, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("İLK HALİ")
   
    S1.Range("D:AG").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 30)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Metin = Split(Veri(X, 1), ", ")
        For Y = LBound(Metin, 1) To UBound(Metin, 1)
            Liste(X, Y + 1) = Metin(Y)
        Next
    Next
   
    S1.Range("D2").Resize(Son, UBound(Liste, 2)) = Liste
    S1.Columns.AutoFit
   
    Set S1 = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Korhan Bey, Sizin ki ilk hali sayfasında çalışıyor. Bir sonraki sütuna C dekilerin aynını aktarım yapıyor.

Korhan Ayhan · 18 Ocak 2021

Ben kodu çalıştırdığımda aşağıdaki görsel oluşuyor;

Muzaffer Ali · 18 Ocak 2021

muratot' Alıntı:
Muzaffer Bey, ilk ayırdığı sütun sorunsuz (boşluk yok) sonraki adlarda boşluk bırakmaya devam ediyor.

Ben kontrol ettiğimde boşlukları sorunsuz kaldırıyor.

Şunu da belirteyim o aradaki boşluk normal boşluk karakteri değil.
Başka bir karakter ama görüntü olarak boşluk gibi görünüyor.

Sorunu çözmek için

Kod:

Cells(Bak, 4 + BakS) = WorksheetFunction.Substitute(Semboller(BakS), " ", "")

Satırındaki " " yerine herhangi semboller arasındaki boşluk gibi görünen karakteri seçip kopyalayın.

muratot · 18 Ocak 2021

Korhan Ayhan' Alıntı:
Ben kodu çalıştırdığımda aşağıdaki görsel oluşuyor;

Ekli dosyayı görüntüle 224611

Ben o adların ayrı ayrı hücrelerde gelmesini istiyordum

muratot · 18 Ocak 2021

Muzaffer Ali' Alıntı:
Ben kontrol ettiğimde boşlukları sorunsuz kaldırıyor.

Şunu da belirteyim o aradaki boşluk normal boşluk karakteri değil.
Başka bir karakter ama görüntü olarak boşluk gibi görünüyor.

Sorunu çözmek için

Kod:

Cells(Bak, 4 + BakS) = WorksheetFunction.Substitute(Semboller(BakS), " ", "")

Satırındaki " " yerine herhangi semboller arasındaki boşluk gibi görünen karakteri seçip kopyalayın.

Aynen dediğiniz gibi yaptım sorun çözültü çok teşekkür ederim..

Korhan Ayhan · 18 Ocak 2021

Eğer eklediğim resmi görüyorsanız sarı renkli hücreler ayrı hücrelerdir.

muratot · 18 Ocak 2021

Korhan Ayhan' Alıntı:
Eğer eklediğim resmi görüyorsanız sarı renkli hücreler ayrı hücrelerdir.

Korhan Bey, Resmi göremiyorum. Tekrar deneyip dönüş yapacağım. Teşekkürler...

muratot · 18 Ocak 2021

muratot' Alıntı:
Aynen dediğiniz gibi yaptım sorun çözültü çok teşekkür ederim..

Muzaffer Ali' Alıntı:
Ben kontrol ettiğimde boşlukları sorunsuz kaldırıyor.

Şunu da belirteyim o aradaki boşluk normal boşluk karakteri değil.
Başka bir karakter ama görüntü olarak boşluk gibi görünüyor.

Sorunu çözmek için

Kod:

Cells(Bak, 4 + BakS) = WorksheetFunction.Substitute(Semboller(BakS), " ", "")

Satırındaki " " yerine herhangi semboller arasındaki boşluk gibi görünen karakteri seçip kopyalayın.

Muzaffer Bey, çok özür dileyerek devam etmek istiyorum. Aslında ben şu an gönderdiğim gibi olmasını istiyorum adları ayırıp kaç kezgeldiğini pivot ilebulabileceğimi düşünmüştüm ama onunda uğraşı çok oluyor. Şu an paylaştığım gibi olma imkanı varmıdır?
(Adın kaç kez çıktığını bulmak isityorum.)

İndir alarmgünlüğü

Dosyayı indir alarmgünlüğü

dosya.co

muratot · 18 Ocak 2021

muratot' Alıntı:
Korhan Bey, Resmi göremiyorum. Tekrar deneyip dönüş yapacağım. Teşekkürler...

Korhan Bey, çok özür dileyerek devam etmek istiyorum. Aslında ben şu an eklediğim excel gibi olmasını istiyorum adları ayırıp kaç kezgeldiğini pivot ilebulabileceğimi düşünmüştüm ama onunda uğraşı çok oluyor. Şu an paylaştığım gibi olma imkanı varmıdır?
(Adın kaç kez çıktığını bulmak isityorum.)

İndir alarmgünlüğü

Dosyayı indir alarmgünlüğü

dosya.co

Korhan Ayhan · 18 Ocak 2021

Peki bir önceki çözüm önerimiz istediğiniz sonucu vermiş miydi?

muratot · 18 Ocak 2021

Korhan Ayhan' Alıntı:
Peki bir önceki çözüm önerimiz istediğiniz sonucu vermiş miydi?

Korhan bey tekrar denedim bende bölmedi

Korhan Ayhan · 18 Ocak 2021

#4 nolu mesajımı revize ettim. Tekrar deneyiniz.

muratot · 18 Ocak 2021

Korhan Ayhan' Alıntı:
#4 nolu mesajımı revize ettim. Tekrar deneyiniz.

Şimdi böldü Korhan Bey

Korhan Ayhan · 18 Ocak 2021

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

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

muratot

İndir Kitap1

Muzaffer Ali

Destek Ekibi

muratot

Korhan Ayhan

Administrator

Muzaffer Ali

Destek Ekibi

muratot

muratot

Korhan Ayhan

Administrator

Muzaffer Ali

Destek Ekibi

muratot

muratot

Korhan Ayhan

Administrator

muratot

muratot

İndir alarmgünlüğü

muratot

İndir alarmgünlüğü

Korhan Ayhan

Administrator

muratot

Korhan Ayhan

Administrator

muratot

Korhan Ayhan

Administrator