• DİKKAT

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

MBUL ve BİRLEŞTİR

leonadies

leonadies

Excel Derya Deniz Bizde Kulaç Atmaya Çalışıyoruz:)
Altın Üye
Katılım
12 Şubat 2015
Mesajlar
520
Excel Vers. ve Dili
Office 2016 TR 64 Bit Windows
Arkdaşlar merhaba A1 hücresinde ;

BEYAZ KALEM, SİYAH ÇANTA, YEŞİL SİLGİ, KIRMIZI KİTAP, SARI MAKAS .....

vb çeşitli renkleri içeren kelimeler var.

İsteğim ise şu; bu hücrede var olan renklerin A2 hücresinde

"BEYAZ SİYAH YEŞİL KIRMIZI SARI ......" şeklinde ayrılması. sırası önemli değil.

Nasıl bir formül atmalıyım ? Her hücrede ayrı ayrı renk ayırıp bir hücrede birleştirme yapabiliyorum ama belki daha pratik bir çözümü vardır
 
Son düzenleme:
Verdiğiniz örneklerin hesap A1 hücresinde mi yazıyor ? Yoksa;

A1'de Beyaz Kalem
A2'de Siyah Çanta

gibi mi ?
 
"BEYAZ KALEM, SİYAH ÇANTA, YEŞİL SİLGİ, KIRMIZI KİTAP, SARI MAKAS ....." bu kısım tamamen bir metin şeklinde A1 hücresi içinde yer alıyor.

Ayırma işlemini A2 hücresi içinde yapmak istiyorum.
 
eğer hücre içeriği RENK ÜRÜN, bu sıralamada gidiyorsa şu kodu deneyiniz.
Kod: 
Sub ayıkla()
Dim dizi() As String
msg = ""

sonSatir = Sayfa1.Range("A10000").End(xlUp).Row

For j = 1 To sonSatir

    tmpStr = Sayfa1.Range("A" & j)
    dizi = Split(tmpStr, ",")
    For i = 0 To UBound(dizi)
        tmpDizi = Split(Trim(dizi(i)), " ")
        msg = msg & tmpDizi(0) & " "
    Next i
    msg = RTrim(msg)
    Sayfa1.Range("B" & j) = msg
    

Next j
End Sub

Eğer KTF (Kullanıcı Tanımlı Fonksiyon) olarak kullanmak isterseniz şu kodları modül içine yazıp, =AYIKLA(A1) olarak B1 hücresine giriniz.
Kod: 
Public Function Ayıkla(Hucre As Range) As String


tmpStr = Hucre.Value
dizi = Split(tmpStr, ",")
For i = 0 To UBound(dizi)
    tmpDizi = Split(Trim(dizi(i)), " ")
    msg = msg & tmpDizi(0) & " "
Next i
msg = RTrim(msg)
Ayıkal = msg

End Function
 
systran' Alıntı:
eğer hücre içeriği RENK ÜRÜN, bu sıralamada gidiyorsa şu kodu deneyiniz.
Kod: 
Sub ayıkla()
Dim dizi() As String
msg = ""

sonSatir = Sayfa1.Range("A10000").End(xlUp).Row

For j = 1 To sonSatir

    tmpStr = Sayfa1.Range("A" & j)
    dizi = Split(tmpStr, ",")
    For i = 0 To UBound(dizi)
        tmpDizi = Split(Trim(dizi(i)), " ")
        msg = msg & tmpDizi(0) & " "
    Next i
    msg = RTrim(msg)
    Sayfa1.Range("B" & j) = msg
    

Next j
End Sub
Genişletmek için tıkla ...


İlginize teşekkür ederim. öncelikle makro sorunsuz çalışıyor. Ancak ürün renk kurgusu düzenli olmayacak. Metinde farklı kelimelerde olabilecek. araya yabancı alakasız şeylerde girebilecek. İsteğim ne yazılırsa yazılsın belli 10 çeşit rengin kelime olarak ayrılmasını istiyorum.
 
Sanırım bir çalıçma eklemek daha mantıklı olacak. Ekteki dosyada amacımı anlatmaya çalıştım.

Makro fonksiyon formül her türlü çözüm olabilir.
 

Ekli dosyalar

Şu kodları deneyiniz.
Kod: 
Sub ayıkla()
Dim renkler(20)         '20 TANE RENK EKLEYEBİLİRSİNİZ.
renkler(1) = "SİYAH"
renkler(2) = "BEYAZ"
renkler(3) = "SARI"
renkler(4) = "KIRMIZI"
renkler(5) = "MOR"
renkler(6) = "YEŞİL"

tmpStr = Sayfa1.Range("A1")
msg = ""
For i = 1 To UBound(renkler)
  sonuc = InStr(1, tmpStr, renkler(i), vbTextCompare)
  if sonuc>0 then
    msg = msg & renkler(i) & " "
  end if
Next i
Sayfa1.Range("B1") = RTrim(msg)
End Sub
 
systran' Alıntı:
Şu kodları deneyiniz.
Kod: 
Sub ayıkla()
Dim renkler(20)         '20 TANE RENK EKLEYEBİLİRSİNİZ.
renkler(1) = "SİYAH"
renkler(2) = "BEYAZ"
renkler(3) = "SARI"
renkler(4) = "KIRMIZI"
renkler(5) = "MOR"
renkler(6) = "YEŞİL"

tmpStr = Sayfa1.Range("A1")
msg = ""
For i = 1 To UBound(renkler)
  sonuc = InStr(1, tmpStr, renkler(i), vbTextCompare)
  if sonuc>0 then
    msg = msg & renkler(i) & " "
  end if
Next i
Sayfa1.Range("B1") = RTrim(msg)
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim tam istedğim gibi :) Peki A sutununda aşağıya doğru akan bu renkleri B sutununda aynı mantıkta aşağı doğru devam ettirebilirmiyim?
Birde Ben A sutununa girdikçe (hemen) B sutununda ayırsın istiyorum. Bu da olursa sorun kalmayacak :)
 
Örnek dosyayı inceleyiniz. Modül içinden istediğiniz renkleri koda ilave etmeyi unutmayınız.
 

Ekli dosyalar

Son düzenleme:
systran' Alıntı:
Örnek dosyayı inceleyiniz. Modül içinden istediğiniz renkleri koda ilave etmeyi unutmayınız.
Genişletmek için tıkla ...

Teşekkür ederim sorunsuz çalışıyor tek sorun Büyük küçük harf duyarlı oluşu. Kodların çalışması için hep büyük harf gerekiyor. Yoksa çalışmıyor. Bunuda çözersek işlem tamamdır :)
 
Pardon sorun olan "İ" ,"Ü" gibi Türkçe büyük karakterler. Bunları çözebilirsek sorun kalmıyor.
 
#9 nolu mesajdaki dosyayı tekrar deneyiniz.
 
bir hata var anlayamadım #9 nolu mesaj Şu an hiç çalışmıyor. Bu arada durum değişmek zorunda kaldı çalışmamda. E sutununa girilenleri G sutununda yakalasın yapabilir miyiz?
Ben makrodaki A ve B leri değiştirdim ama olmadı. Sebebini çözmeye uğraşıyordum
 
Sub ayıkla(satır As Integer)
Dim renkler(20) '20 TANE RENK EKLEYEBİLİRSİNİZ.
renkler(1) = "SİYAH"
renkler(2) = "BEYAZ"
renkler(3) = "SARI"
renkler(4) = "KIRMIZI"
renkler(5) = "MOR"
renkler(6) = "YEŞİL"
renkler(7) = "TURUNCU"



tmpStr = UCase(Sayfa1.Range("A" & satır)) 'Hücreyi Büyük harfe dönüştürür
tmpStr = Replace(tmpStr, "i", "İ") 'i --> İ yapar
tmpStr = Replace(tmpStr, "ş", "Ş") 'ş --> Ş yapar
tmpStr = Replace(tmpStr, "ı", "I") 'ı --> I yapar
tmpStr = Replace(tmpStr, "ç", "Ç") 'ç --> Ç yapar
tmpStr = Replace(tmpStr, "ğ", "Ğ") 'ğ --> Ğ yapar
tmpStr = Replace(tmpStr, "ö", "Ö") 'ö --> Ö yapar
tmpStr = Replace(tmpStr, "ü", "Ü") 'ü --> Ü yapar



msg = ""
For i = 1 To UBound(renkler)
sonuc = InStr(1, tmpStr, renkler(i), vbTextCompare)
If sonuc > 0 Then
msg = msg & renkler(i) & " "
End If
Next i
Sayfa1.Range("B" & satır) = RTrim(msg)

End Sub
Genişletmek için tıkla ...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
Application.EnableEvents = False
ayıkla (Target.Row)
Application.EnableEvents = True
End Sub
Genişletmek için tıkla ...


Sorun nedir acaba ?
 
Bu konuda takılıp kaldım. Sizden başka yazanda olmadı. İnternetin altını üstüne getirdim ancak bu tarz bir konu hiç yok. Müsadenizle bunu başka bir başlıkla (Hücre İçinde Belli Kelimeleri Ayırmak) forumda açabilir miyim? Eminim ihtiyacı olan birileri yine olacaktır. Faydalanabilir diye düşünüyorum.( bu mesajı size özel olarak yazmaya çalıştım ancak engelledi sistem)
 
sütun kontrolünü 'If Target.Column <> 1 Then Exit Sub' bu koddaki 1 yapar. 1. sütun A sütunu
bunu değiştirin.
A ve B yi E ve G olarak değiştirmeyi de unutmayın.
 
Benzer alternatif;

Kod "A" sütununda çalışmaktadır. Kırmızı bölümü dilediğiniz gibi değiştirebilirsiniz.
"A" sütununda veri girişi yaptığınızda sonucu "B" sütununda gösterir.

Fonksiyondaki Renkler bölümüne dilediğiniz kadar renk ekleyebilirsiniz.

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then Exit Sub
    If Target.Value <> "" Then
        Target.Offset(0, 1).Value = Renk_Bul(Target)
    End If
End Sub

Function Renk_Bul(Veri As Variant) As String
    Dim Renkler As Variant, X As Integer, Bul As Integer
    Renkler = Array("BUZ MAVİSİ", "SU YEŞİLİ", "SİYAH", "BEYAZ", "SARI", "KIRMIZI", "YEŞİL", "MAVİ", "LACİVERT", "KAHVERENGİ", "TURUNCU", "MOR")
    For X = 0 To UBound(Renkler)
        Bul = InStr(1, UCase(Replace(Replace(Veri.Value, "ı", "I"), "i", "İ")), Renkler(X))
        If Bul > 0 Then
            Renk_Bul = IIf(Renk_Bul = "", Mid(Veri.Value, Bul, Len(Renkler(X))), Renk_Bul & " " & Mid(Veri.Value, Bul, Len(Renkler(X))))
        End If
    Next
End Function
 
Korhan Bey teşekkür ederim. Kodları problemsiz istediğim yerde ve istediğim renk adedince kullanıyorum.
Sorun olan sadece iki kelimelik renkleri tanımlayamıyorum.
Örneğin "Buz mavisi, Su yeşili"
bunun için bir düzenleme yapılabilir mi?
 
Üstteki mesajımda ki kodu güncelledim.

Dikkat etmeniz gereken nokta iki kelime olan renkleri fonksiyon içinde en başa yazmanızdır.

Bu durumda da şöyle bir problem oluşuyor.

Örnek;

Suyun rengi buz mavisidir.

Bu veriden oluşan sonuç; buz mavisi mavi

Yani "mavi" yazısı iki defa listeleniyor. Eğer hücrelere veri girişinde tek renk yazıyorsanız sorun aşılabilir. Aksi durumda sıkıntılı bir durum oluşuyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst