Bir sütunun başka bir sütuna kopyalanması

[ereneren492]

Merhaba,
Bir sütundaki tüm hücreleri ilk 2 kelimesi ile birlikte başka bir sütuna kopyalamak için koda ihtiyacım var, yardımcı olursanız sevinirim.
Teşekkürler

 

[Cengiz Demir]

Verileriniz AAA BBB CCC DDD gibiyse (aralarında boşluk olmalı)
Bu formül işinizi görür.

=PARÇAAL(A8;1;MBUL(" ";A8;MBUL(" ";A8)+1)-1)

 

[ereneren492]

Teşekkürler, Ancak bana VBA kodları lazım.

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz. A sütunundaki tüm verileri istediğiniz gibi B sütununa aktarır:

Sub ayirma()
son = Cells(Rows.Count, "A").End(3).Row
For i = 1 To son
    If Cells(i, "A") <> "" Then
        If Len(Trim(Cells(i, "A"))) <> Len(Replace(Trim(Cells(i, "A")), " ", "")) Then
            veri = Split(Trim(Cells(i, "A")), " ")
            Cells(i, "B") = veri(0) & " " & veri(1)
        End If
    End If
Next
End Sub

 

[Cengiz Demir]

Ben bu kodları hazırlarken @YUSUF44 üstad, benden önce davranmış (Eline sağlık.)
Bu da alternatif olsun.

Evaluate komutu için @Korhan Ayhan üstada da ayrıca teşekkürler. Onun bir çözümünde gördüm bu komutu

Dim i As Long
Dim hcr As String

Sub KelimeAl()

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    hcr = "MID(A" & i & ",1,SEARCH("" "",A" & i & ",SEARCH("" "",A" & i & ")+1)-1)"
    Cells(i, 2) = Evaluate(hcr)
Next i

End Sub

 

[ereneren492]

Çok teşekkür ederim yardımınız için, süper oldu

Birde sheet içerisindeki herhangi bir hücrede "XXX" ifadesi olan satırı silebileceğim kodu paylaşabilir misiniz?

 

[Cengiz Demir]

Başka bir yerden bulduğum kodu isteğinize göre uyarladım.
Makro A1-D15 referansı arasında işlem yapıyor. Kendi sayfanıza göre uyarlarsınız.

Sub FindString()
    Dim c As Range
    Dim firstAddress As String

    With Range("A1:D15")
        Set c = .Find("xxx", LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.EntireRow.Delete
                Set c = .Find("xxx", LookIn:=xlValues)
            Loop While Not c Is Nothing
        End If
    End With

End Sub

 

[Cengiz Demir]

İnternette kopma olmuştu. Değiştir yaparken ikinci mesaj oluştu. İçeriği sildim ..

 

[ereneren492]

Cengiz hocam hızlı desteğiniz için çok teşekkürler. Çok sordum biliyorum ama bir sorum daha var

B sütunu içinde yazan "XXX" ifadesini kopyalayıp L sütunundaki aynı satıra denk gelen hücreye, "YYY" ifadesini kopyalayıp yine L sütunundaki aynı satıra denk gelen hücreye yazmak istiyorum.

şimdiden teşekkürler.

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub LyeAktar()
son = Cells(Rows.Count, "B").End(3).Row
    For i = 1 To son
        If Cells(i, "B") = "xxx" Or Cells(i, "B") = "yyy" Then
            Cells(i, "L") = Cells(i, "B")
        End If
    Next
End Sub

 

[ereneren492]

Selamlar,
Kod bir hata vermiyor ancak B sütunundaki XXX veya YYY olan ifadeleri L sütununa yazmıyor.

 

[ereneren492]

B sütununda bir kaç kelime var, kelimelerden biri de XXX veya YYY. Sorun bu yüzden olabilir mi? Ben sadece XXX veya YYY kelimesini çekip L sütununa yazmak istiyorum.

 

[YUSUF44]

Deneyiniz:

Sub varsaaktar()
son = Cells(Rows.Count, "B").End(3).Row
    For i = 1 To son
        If Len(Cells(i, "B")) <> Len(Replace(Cells(i, "B"), "xxx", "")) Then
            Cells(i, "L") = "xxx"
        ElseIf Len(Cells(i, "B")) <> Len(Replace(Cells(i, "B"), "yyy", "")) Then
            Cells(i, "L") = "yyy"
        End If
    Next
End Sub

 

[ereneren492]

Teşekkür ederim, bu süper oldu.

 

[ereneren492]

Selamlar, excel dosyamda birde türkçe karakter sorunu var. Sheet içindeki türkçe karakter içeren kelimelerde kodlar çalışmıyor ya da kod ile herhangi bir hücreye ekleme yaptığımda türkçe karakterler hatalı çıkıyor. Bunu nasıl düzeltiriz?