HÜcredekİ Bİlgİlerİ DaĞitma

[cuneyt001]

A1 - Hücresinde

Adana Merkez Ali Yılmaz 555214121 Cumhuriyet Mh. Ali Sok. No: 4
Yazıyor...

görüldüğü üzere bilgiler, aynı hücre içinde olmasına rağmen, farklı farklı karakter ve renklerle ayrılmışlar.

Ben bu bilgileri, yandaki hücrelereyaymak istiyorum.

1. Hücreye (İL)
2. Hücreye (İLÇE)
3. Hücreye (Adı Soyad&#305
4. Hücreye (Telefon Numaras&#305
5. Hücreye (Adres)


Bilgilerin sadece renk ve yazı kakteri farklılıkları var. ve hepsi aynı hücrede.

Şimdi bu bilgileri nasıl, hücre içinden alıp, yanındaki hücrelere yayabilirim.

 

[Merhum İdris SERDAR]

Data/Text to Column'dan yapabilirsiniz.

Türkçesi Veri/ Metni Sütunlara dönüştür olması lazım.

Burada çıkan yönergeleri takip edin.

.

 

[cuneyt001]

nasıl yapacağımı anlamadım... daha detaylı bilgiyi nerden bulabilirim.

 

[Merhum İdris SERDAR]

nasıl yapacağımı anlamadım... daha detaylı bilgiyi nerden bulabilirim.

Ekteki dosyayı inceleyin.

Biraz da sınama yanılma yöntemi ile bulmaya çalışın.

.

 

[ziya]

Sn cuneyt001
Bu konuda kapsamlı bir çalışma. Çalışma Necdet Yeşertener'e aittir. Sitede aramama rağmen bulamadım. Bu nedenle bu çalışmayı tekrar yüklüyorum. İşinizi çözecektir. (Necdet bey'e teşekkürler)
Selamlar,

 

[Ferhat Pazarçevirdi]

Renklere göre ayrım yapmak için; aşağıdaki kodu kullanabilirsiniz.

NOT : Örnek dosyayı inceleyiniz.

Option Explicit
Sub Kelime_Ayir()
    Dim i As Integer
    Dim j As Integer
    
    For i = 1 To Cells(65536, 1).End(xlUp).Row
        For j = 1 To Len(Cells(i, 1))
                Select Case Cells(i, 1).Characters(Start:=j, Length:=1).Font.ColorIndex
                    Case 1:
                        If Cells(i, 1).Characters(Start:=j, Length:=1).Font.Name = "Arial Black" Then
                            Cells(i, 6) = Cells(i, 6) & Mid(Cells(i, 1), j, 1)
                        Else
                            Cells(i, 2) = Cells(i, 2) & Mid(Cells(i, 1), j, 1)
                        End If
                    Case 3: Cells(i, 3) = Cells(i, 3) & Mid(Cells(i, 1), j, 1)
                    Case 5: Cells(i, 4) = Cells(i, 4) & Mid(Cells(i, 1), j, 1)
                    Case 10: Cells(i, 5) = Cells(i, 5) & Mid(Cells(i, 1), j, 1)
                    Case Else: Cells(i, 6) = Cells(i, 6) & Mid(Cells(i, 1), j, 1)
                End Select
        Next j
    Next i
                
End Sub

 

[cuneyt001]

A1 - Hücresinde

Adana Merkez Ali Yılmaz 555214121 Cumhuriyet Mh. Ali Sok. No: 4
Yazıyor...


Şimdi şöyle bir sorunum var. Gönderdiğiniz dosyayı inceledim.

Hücre içindeki bilgilerin tek ortak yanı, karakter, ve renkleri.

Yani benim örneğimi değiştiriyorum.


Adana Ceyhan 100. Yıl Sarısakal İÖO 322 444 44 44 Sarısakal Mah. 225 Sk. No 12 Ceyhan

Bilgi bu.

Ancak bu bilgi satırında, adreste (Sarısakal Mah. 225 Sk. No 12 Ceyhan) 7 kelime var. alt satırdaki adreste 3 kelime var.

kimi satırda okulun adı 3 kelime, kimisinde 5 kelime...

Dolayısıyla METNİ SÜTUNLARA DÖNÜŞTÜR sekmesini kullandığımda, sadece en baştaki, 2 kelimeyi doğru bölebiliyorum. Onlarda İL ve İLÇE.

ama diğer cümleler, kimisi 3 cümle kimisi 4 cümle... eşit dağılım olmuyor... Ben karakter ve yazı tiplerine göre bölme metni, sütunlara dönüştürebilir miyim=?

 

[cuneyt001]

Ferhat Bey, Yaptığınız örnek çalışmayı gördüm... ve ŞOKTAYIM!!!

Benim gönderdiğim excel dosyası üzerinden bunu yapabilir miyiz. ?

 

[Ferhat Pazarçevirdi]

Orjinal dosyanıza aşağıdaki kodu ilave edin.

Ancak, font renklerinde siz göremeseniz de; (özellikle boşluk/space/" " renklendirmesi) Telefon No'yu ayırmak biraz problem çıkardı. Bence üzerinde çok durulacak bir problem değil. veya örneğe özgü olabilir.

Belki, biraz daha kafa yorulsa, o sütuna da birşeyler yapılabilir ama siz yine bir inceleyiniz.

Option Explicit
Sub Kelime_Ayir()
    
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim ilkrenk As Integer
    Dim sonrenk As Integer
    Dim x As Integer
    
    k = 1
    For i = 2 To Cells(65536, 1).End(xlUp).Row
        
        For j = 1 To Len(Cells(i, 1))
                ilkrenk = Cells(i, 1).Characters(j, 1).Font.ColorIndex
                
                
                If ilkrenk <> sonrenk Then
                    sonrenk = Cells(i, 1).Characters(j, 1).Font.ColorIndex
                    k = k + 1
                End If
                
                If ilkrenk = 5 And Cells(i, 1).Characters(j, 1).Text = "f" Then
                    x = x + 1
                    If x = 1 Then
                        k = k + 1
                    End If
                End If
                
                Cells(i, k) = Cells(i, k) & Mid(Cells(i, 1), j, 1)
                
        Next j
        
        k = 1
        ilkrenk = 0
        sonrenk = 0
        x = 0
    Next i
                
End Sub

 

[cuneyt001]

Evet orjinal dosyayı koydum... Ama yine hatalar var... Mesela bazı okullar 100. yıl diye başlıyor. Onu hatalı koyuyor.


Birde bazı okulların fax numaraları yok... Fax ları olduğu zaman f ile başlıyor... olmadı zaman, direkt adrese gidiyor.

Şu an makroyu tüm dosya da çalıştırdım.. Toplam 8000'e yakın satır var. Bakalım bitirdiğinde tüm hatalara bakacağım.

 

[veyselemre]

Sayın cuneyt001,

Merakımdan soruyorum, herhalde verileriniz excel kullanılarak bu şekilde renklendilmedi. Verilerin kaynağı nedir, web sayfasından mı, bir programdan mı kopyala yapıştırıldı merak ettim.

 

[Ferhat Pazarçevirdi]

Ekteki dosyayı inceleyiniz. "% 100 sonuç verir" diyemiyorum. Çünkü, daha önce de belirttiğim gibi, bilgilerin renklendirilmesinde belirli bir düzen yok. Gözle görülmeyen, renklendirmeler mevcut. Ama yine de, test ettiğim kadarıyla % 95 verim alabilirsiniz. Gerisini elle düzeltebilirsiniz.

Ekteki dosyayı inceleyiniz. (Orjinal dosyanızın bir parçası)

Aşağıdaki kodlar kullanıldı. (Biraz derme çatma ama idare eder)

Option Explicit
Sub Kelime_Ayir()
    
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim ilkrenk As Integer
    Dim sonrenk As Integer
    Dim x As Integer
    Dim son As Integer
    k = 1
    son = Cells(65536, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 2 To son
        
        For j = 1 To Len(Cells(i, 1))
                ilkrenk = Cells(i, 1).Characters(j, 1).Font.ColorIndex
                
                
                If ilkrenk <> sonrenk Then
                    sonrenk = Cells(i, 1).Characters(j, 1).Font.ColorIndex
                    k = k + 1
                End If
                
                If ilkrenk = 5 And Cells(i, 1).Characters(j, 1).Text = "f" Then
                    x = x + 1
                    If x = 1 Then
                        k = k + 1
                    End If
                End If
                
                Cells(i, k) = Cells(i, k) & Mid(Cells(i, 1), j, 1)
                
                If Cells(i, k) = " " Then
                   k = k - 1
                End If
        
                If k = 6 And ilkrenk = 5 And Len(Cells(i, 6)) = 7 Then
                    If Mid(Cells(i, 1), j, 1) = "f" Then
                        k = 7
                    Else
                        k = k + 1
                    End If

                End If
                
                
        Next j
        
        k = 1
        ilkrenk = 0
        sonrenk = 0
        x = 0
        
        If Cells(i, "I") <> Empty Then
            Cells(i, "G").Delete Shift:=xlToLeft
        End If
        Application.StatusBar = i & "/" & son & " nolu satır işleniyor ... " & "% " & Int((i / son) * 100)
        DoEvents
    Next i
                
    Application.ScreenUpdating = False
    Application.StatusBar = ""

End Sub