Adres yazılı satırdan bölerek veri aktarma

[kelkitli]

Değerli Dostlar Selamlar,
Ekteki dosyada şöyle bir işlemi yapamadım. Sayfa1 C12:C13 hücrelerine Sayfa3 I sütunundan adres bilgilerini aktarmak istiyorum. Ancak C12 Hücresine sığmadığından Adres satırındaki siyah renkle yazılan bilgi C12 hücresine Kırmızı renkle yazılan bilgi de C13 Hücresine yazılsın ama Sayfa1 e aktarılırken kırmızı renk kullanılmasın. Kaydet deyince de Sayfa1 C12 deki veri Sayfa3 I sütununa ön kısıma siyah, Sayfa1 C13 deki bilgi ise Sayfa3 I sütununda ki C12 hücresinden aktarılan verinin arkasına kırmızı renkli olarak birlrştirilsin diye düşündüm. Yardımcı olabilecek arkadaşlara teşekkürlerimi iletiyorum.

 

[kelkitli]

Yada şöyle özetliyeyim. [A1]=[B1] şeklinde bir kod olsun. B1 de karışık renkli harfler olsun. Sırasına göre ilk kırmızı harften sonraki veriyi A1 e aktaralım.

 

[Skorpiyon]

Sayın kelkitli,

Özel bir durum mu söz konusu acaba ?

Neden hücredeki bir veriyi ayırmak için uğraşıyorsunuz ? Bunun yerine Sayfa3 - I sütunundaki Kırmızı renkli veriyi ayrı bir sütuna yazın ve o şekilde deneyin derim.

 

[kelkitli]

Sayın Sertkaya şu sebepten: Kodları incelediyseniz buraya bir sütun ekleyince makroları da yeniden ayarlamam gerekecek. Bir karışıklık olsun istemedim. Bir de yaklaşık 8000 satır veri var. Malum Ankara C plaka. Bir de bölünmüş adres bilgieri biçim olarak çirkin görünür diye düşündüm. Belki ben daha matıklı düşünememişimdir. Belki daha mantıklı öneriler de olur diye foruma yazdım. Cevabınız için de teşekkür ederim Sayın Sertkaya.

 

[Ferhat Pazarçevirdi]

Bul adlı makronuzu aşağıdaki gibi değiştiriniz.

Sub bul()
    Dim s1 As Worksheet
    Dim s2 As Worksheet
    Dim ara As Range
    Dim rg As Range
    Dim klm1 As String
    Dim klm2 As String
    Dim i As Integer
    
    Set s1 = Sayfa1
    Set s3 = Sayfa3
    
    With s1
        
        .Range("c11:c20") = ClearContens
        .Range("H11:H20") = ClearContens
        .Range("M11:M20") = ClearContens
        .Range("a22") = ClearContens
        
        If IsEmpty(.Range("Q3")) Then
            Set s1 = Nothing: Set s2 = Nothing
            Exit Sub
        End If
        
        Set ara = s3.Columns(2).Find(.Range("Q3"), Lookat:=xlWhole)
        
        If Not ara Is Nothing Then
            .Range("C11") = ara.Offset(0, 1).Value
            Set rg = ara.Offset(0, 7)
            
            For i = 1 To rg.Characters.Count
                
                If rg.Characters(i, 1).Font.ColorIndex = 3 Then
                    klm1 = klm1 & rg.Characters(i, 1).Text
                Else
                    klm2 = klm2 & rg.Characters(i, 1).Text
                End If
            
            Next
            
            .Range("C12") = klm2
            .Range("C13") = klm1
            
            .Range("C14") = "06 " & "C " & ara.Offset(0, 0).Value
            .Range("C15") = ara.Offset(0, 12).Value
            .Range("C16") = ara.Offset(0, 13).Value
            .Range("C17") = ara.Offset(0, 14).Value
            .Range("C18") = ara.Offset(0, 15).Value
            .Range("C19") = ara.Offset(0, 16).Value
            .Range("C20") = ara.Offset(0, 17).Value
        
        End If
    End With
    
    Set rg = Nothing
    Set ara = Nothing
    Set s1 = Nothing
    Set s2 = Nothing
    
End Sub

 

[kelkitli]

Sayın Ferhat Bey,
Cevabınızdan dolayı çok çok teşekkür ederim. Bul makrosu çok güzel oldu. Ancak kaydet makrosu da benim için bir o kadar zor. Sizin makronuzu referans alarak yapmaya çalışacağım. İnşallah olur. c12 Hücresi siyah renk, C13 kırmızı renk olması kaydı ile birleştirip Sayfa3 I sütununa aktarmaya çalışacağım. Eğer imkânınız olursa yardımınızı beklerim. Elinize emeğinize sağlık. Çok insanlığa geçti.