• DİKKAT

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

Değere göre Text to Columns

O

ottoman71

Katılım
27 Ocak 2010
Mesajlar
207
Excel Vers. ve Dili
Excel 2010 VB Makro
Merhaba Arkadaşlar,
M sütunundaki değerleri; B, C ve D sütunda gösterildiği gibi değere göre makro ile ayırabilirmiyiz.

Ekteki dosyada biraz daha detaylı anlatılmıştır.

Teşekkur ederim
 

Ekli dosyalar

Merhaba,

Bu şekilde deneyiniz..

Kod: 
Sub Veri_Düzenle()
Application.ScreenUpdating = False
[B:D].ClearContents
    For i = 1 To [M65536].End(3).Row
        For j = 1 To Len(Cells(i, "M"))
            If Not IsNumeric(Mid(Cells(i, "M"), j, 1)) Then
                Harf = Harf & Mid(Cells(i, "M"), j, 1)
            End If
        Next j
        Cells(i, "B") = Harf: Harf = ""
        Cells(i, "B") = Split(Cells(i, "B"), "x")(0)
        If Left(Cells(i, "M"), 1) <> "P" Then
            Cells(i, "B") = Cells(i, "B") & " " & Split(Cells(i, "M"), Cells(i, "B"))(1)
        Else
            Cells(i, "C") = Split(Split(Cells(i, "M"), Cells(i, "B"))(1), "x")(0)
            Cells(i, "D") = Split(Split(Cells(i, "M"), Cells(i, "B"))(1), "x")(1)
        End If
    Next i
Application.ScreenUpdating = True
End Sub

.
 
merhaba

bu kod işinizi görür mü?

Kod: 
Sub sutunlaraayir()
ss = Range("m65536").End(xlUp).Row
For i = 1 To ss
If Not Left(Cells(i, "m"), 2) = "PL" Then
Cells(i, "b") = Left(Cells(i, "m"), 3) & " " & Right(Cells(i, "m"), (Len(Cells(i, "m")) - 3))
Else:
Cells(i, "b") = Left(Cells(i, "m"), 2)
Cells(i, "c") = Mid(Cells(i, "m"), 3, 2)
Cells(i, "d") = Right(Cells(i, "m"), 3)
Cells(i, "d") = Application.WorksheetFunction.Substitute(Cells(i, "d"), "x", "")
End If
Next
End Sub
 
Ömer' Alıntı:
Merhaba,

Bu şekilde deneyiniz..

Kod: 
Sub Veri_Düzenle()
Application.ScreenUpdating = False
[B:D].ClearContents
    For i = 1 To [M65536].End(3).Row
        For j = 1 To Len(Cells(i, "M"))
            If Not IsNumeric(Mid(Cells(i, "M"), j, 1)) Then
                Harf = Harf & Mid(Cells(i, "M"), j, 1)
            End If
        Next j
        Cells(i, "B") = Harf: Harf = ""
        Cells(i, "B") = Split(Cells(i, "B"), "x")(0)
        If Left(Cells(i, "M"), 1) <> "P" Then
            Cells(i, "B") = Cells(i, "B") & " " & Split(Cells(i, "M"), Cells(i, "B"))(1)
        Else
            Cells(i, "C") = Split(Split(Cells(i, "M"), Cells(i, "B"))(1), "x")(0)
            Cells(i, "D") = Split(Split(Cells(i, "M"), Cells(i, "B"))(1), "x")(1)
        End If
    Next i
Application.ScreenUpdating = True
End Sub

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


Hocam çok teşekkur ediyorum. Kod istediğim gibi çalışıyor.Ellerinize sağlık.
 
uzmanamele' Alıntı:
merhaba

bu kod işinizi görür mü?

Kod: 
Sub sutunlaraayir()
ss = Range("m65536").End(xlUp).Row
For i = 1 To ss
If Not Left(Cells(i, "m"), 2) = "PL" Then
Cells(i, "b") = Left(Cells(i, "m"), 3) & " " & Right(Cells(i, "m"), (Len(Cells(i, "m")) - 3))
Else:
Cells(i, "b") = Left(Cells(i, "m"), 2)
Cells(i, "c") = Mid(Cells(i, "m"), 3, 2)
Cells(i, "d") = Right(Cells(i, "m"), 3)
Cells(i, "d") = Application.WorksheetFunction.Substitute(Cells(i, "d"), "x", "")
End If
Next
End Sub
Genişletmek için tıkla ...

Hocam çok teşekkur ediyorum. Kod istediğim gibi çalışıyor.Ellerinize sağlık.
 
Üstadlarım ikinizede ayrı ayrı teşekkurü borç bildim. Ellerinize sağlık
 
Ömer' Alıntı:
Merhaba,

Bu şekilde deneyiniz..

Kod: 
Sub Veri_Düzenle()
Application.ScreenUpdating = False
[B:D].ClearContents
    For i = 1 To [M65536].End(3).Row
        For j = 1 To Len(Cells(i, "M"))
            If Not IsNumeric(Mid(Cells(i, "M"), j, 1)) Then
                Harf = Harf & Mid(Cells(i, "M"), j, 1)
            End If
        Next j
        Cells(i, "B") = Harf: Harf = ""
        Cells(i, "B") = Split(Cells(i, "B"), "x")(0)
        If Left(Cells(i, "M"), 1) <> "P" Then
            Cells(i, "B") = Cells(i, "B") & " " & Split(Cells(i, "M"), Cells(i, "B"))(1)
        Else
            Cells(i, "C") = Split(Split(Cells(i, "M"), Cells(i, "B"))(1), "x")(0)
            Cells(i, "D") = Split(Split(Cells(i, "M"), Cells(i, "B"))(1), "x")(1)
        End If
    Next i
Application.ScreenUpdating = True
End Sub

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



Application.ScreenUpdating = False
For i = 1 To [E65536].End(3).Row
For j = 1 To Len(Cells(i, "E"))
If Not IsNumeric(Mid(Cells(i, "E"), j, 1)) Then
Harf = Harf & Mid(Cells(i, "E"), j, 1)
End If
Next j
Cells(i, "U") = Harf: Harf = ""
Cells(i, "U") = Split(Cells(i, "U"), "x")(0)
If Left(Cells(i, "E"), 1) <> "P" Then
Cells(i, "U") = Cells(i, "U") & " " & Split(Cells(i, "E"), Cells(i, "U"))(1)
Else
Cells(i, "V") = Split(Split(Cells(i, "E"), Cells(i, "U"))(1), "x")(0)
Cells(i, "W") = Split(Split(Cells(i, "E"), Cells(i, "U"))(1), "x")(1)
End If
Next i
Application.ScreenUpdating = True

Ömer hocam;
M'deki verileri B,C ve D'ye text to columns yapmıştık. Ben kodları E'deki veriler U,V ve W'ye text to columns olarak değiştirdim.
Fakat "E" ile "S" sütunu arasında başka veriler olduğundan yukarıda kodlarda kırmızı ile işaretlediğim yerde "subscript out of range" hatası veriyor.

Yardımcı olabilirmisiniz.
 
E ile S arasındaki değerler silinmemesi mi gerekiyor. Üstüne yazılacaksa silimesinde mahsur yok. Clear komutundaki aralığıda değiştirdiniz mi?

.
 
Ömer' Alıntı:
E ile S arasındaki değerler silinmemesi mi gerekiyor. Üstüne yazılacaksa silimesinde mahsur yok. Clear komutundaki aralığıda değiştirdiniz mi?

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

Hayır silinmeyecek hocam. Sadece ayırma işlemi yapacak.
Olabiliyorsa E sütunundaki değerleri aynı mantık ile E,F,G olarak ayırırsa daha iyi olacak.yani başka bir yere kopya almadan text to columns yapıcak.

eğer fazla uğraştıracaksa gerek yok. U,V ve W sütunundan E,F,G sütununa taşırım.

Teşekkur ederim.
 
Soruyu anlayamadım. Küçük bir örnek ekleyerek dosya üzerinde olması gerekeni detaylı açıklarmısınız. Şuan zaman bulamazsam akşam bakıp geri dönüş yaparım.

.
 
Ömer' Alıntı:
Soruyu anlayamadım. Küçük bir örnek ekleyerek dosya üzerinde olması gerekeni detaylı açıklarmısınız. Şuan zaman bulamazsam akşam bakıp geri dönüş yaparım.

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


Hocam dosyayı ayrıntılı olarak eklemeye anca vaktim oldu.
Dosya ektedir.
Kolay gelsin.
 

Ekli dosyalar

Bu şekilde deneyiniz..

Kod: 
Sub Veri_Düzenle()
Application.ScreenUpdating = False
On Error Resume Next
[F:G,M:M].ClearContents
    For i = 2 To [E65536].End(3).Row
        For j = 1 To Len(Cells(i, "E"))
            If Not IsNumeric(Mid(Cells(i, "E"), j, 1)) Then
                Harf = Harf & Mid(Cells(i, "E"), j, 1)
            End If
        Next j
        Cells(i, "M") = Harf: Harf = ""
        Cells(i, "M") = Split(Cells(i, "M"), "x")(0)
        If Left(Cells(i, "E"), 1) <> "P" Then
            Cells(i, "M") = Cells(i, "M") & " " & Split(Cells(i, "E"), Cells(i, "M"))(1)
        Else
            Cells(i, "F") = Split(Split(Cells(i, "E"), Cells(i, "M"))(1), "x")(0)
            Cells(i, "G") = Split(Split(Cells(i, "E"), Cells(i, "M"))(1), "x")(1)
        End If
    Next
Application.ScreenUpdating = True
End Sub

.
 
Hocam bu dosya üzerinde başka bir sorum daha olacak.
D sütununa verileri birleştirmek istiyorum
D2'den başlayacak boş satıra kadar devam edecek.
D2= "M2";",";" ";"L2" ====> şeklinde olacak
D3= "M3";",";" ";"L3"
D4= "M4";",";" ";"L4"
D5= "M5";",";" ";"L5".............. şeklinde boş satıra kadar devam edecek.

Yardımcı olabilirmisiniz.
 
Tam olarak istediğiniz belli olmuyor. Daha detaylı açıklarmısınız.

Kod: 
Sub Birleştir()
Application.ScreenUpdating = False
[D:D].ClearContents
    For i = 2 To [M65536].End(3).Row
        Cells(i, "D") = Cells(i, "M") & "; , ; ;" & Cells(i, "L")
    Next i
Application.ScreenUpdating = True
End Sub
İstediğiniz bu mu?
 
Hocam Teşekkur ederim.
Bir yerde hatalı olmuştu işaretli yeri düzelttim.

Sub Birleştir()
Application.ScreenUpdating = False
[D: D].ClearContents
For i = 2 To [M65536].End(3).Row
Cells(i, "D") = Cells(i, "M") & ", " & Cells(i, "L")
Next i
Application.ScreenUpdating = True
End Sub
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst