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

Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
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?

 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
5,801
Excel Vers. ve Dili
2019 Türkçe
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
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,314
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
5,801
Excel Vers. ve Dili
2019 Türkçe
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
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
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.
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,314
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ben kodu çalıştırdığımda aşağıdaki görsel oluşuyor;

224611
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
5,801
Excel Vers. ve Dili
2019 Türkçe
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.
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,314
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Eğer eklediğim resmi görüyorsanız sarı renkli hücreler ayrı hücrelerdir.
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
Aynen dediğiniz gibi yaptım sorun çözültü çok teşekkür ederim..
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.)
 
Katılım
17 Ocak 2019
Mesajlar
31
Excel Vers. ve Dili
Office 2013
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.)
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,314
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Peki bir önceki çözüm önerimiz istediğiniz sonucu vermiş miydi?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,314
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
#4 nolu mesajımı revize ettim. Tekrar deneyiniz.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,314
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
 
Üst