Verileri İlk boşuğundan Sonrasını silmek.!

[sensizsoldum]

Merhaba,
Bir buton yardımıyla J3:J aralığında bulunan verileri kırpmam(silmek) gerekiyor. Örnek dosya ile anlatmak isterdim ama şirkette olduğumdan dosya ekleyemiyorum. Kısaca anlatmak gerekirse, buton tıklandığında J3:J aralığında bulunan verileri ilk boşluğundan sonrasını silmek.
Mesela Osman BAĞRIYANIK yazıyor buton tıklandığından Osman dan dan sonrasını silsin istiyorum Yaklaşık bu şekilde 20.000 tekâmül eden veri mevcut. Hızlı bir makro gerekiyor. Yardımcı olursanız memnun olurum. İyi çalışmalar dilerim.

 

[Huseyinkis]

Ekteki kodları denermisiniz.

Sub Makro1()
For i = 3 To Cells(Rows.Count, "J").End(3).Row
Uzn = 0
For a = 1 To Len(Cells(i, "J"))
İsm = Mid(Cells(i, "J"), a, 1)
If İsm = " " Then
Cells(i, "J").Value = Mid(Cells(i, "J"), 1, Uzn)
GoTo adım:
Else
Uzn = Uzn + 1
End If
Next a
adım:
Next i
End Sub

 

[sensizsoldum]

Hüseyin Bey Merhaba,
İlginiz için teşekkür ederim. Kodlar güzel Hızlı fakat bu işlem için çok yavaş. Böyle anlık işlem lazım bana. Bu şekilde bir işlem lazım.
Teşekkürler.

 

[YUSUF44]

Şu kodu dener misiniz:

Sub Makro1()
'
' Makro1 Makro
'

'
    Columns("K:K").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("K3").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],FIND("" "",RC[-1])-1)"
    Range("K3").Select
    a = Range("j" & Rows.Count).End(xlUp).Row
    Selection.AutoFill Destination:=Range("k3:k" & a)
    Range("k3:k" & a).Select
    Selection.Copy
    Range("j3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
     Range("j3").Select
End Sub

J ile K arasına boş bir sütun ekleyip formülle J sütunundaki ilk kelimeyi K yeni sütuna alır, yeni sütunu kopyalayıp J sütununa yapıştırır, yeni sütunu siler.

 

[Huseyinkis]

Hüseyin Bey Merhaba,
İlginiz için teşekkür ederim. Kodlar güzel Hızlı fakat bu işlem için çok yavaş. Böyle anlık işlem lazım bana. Bu şekilde bir işlem lazım.
Teşekkürler.

Merhaba ekteki kodları denermisiniz. 950.000 satırı 40 saniyede tamamladı.

Sub Makro1()
Application.Calculation = xlCalculationManual
Dim dizi1(1 To 1000000)
For i = 3 To Cells(Rows.Count, "J").End(3).Row
sat = sat + 1
dizi1(sat) = Cells(i, "J")
Next i

For x1 = 1 To sat
Uzn = 0
For a = 1 To Len(dizi1(x1))
İsm = Mid(dizi1(x1), a, 1)
If İsm = " " Then
dizi1(x1) = Mid(dizi1(x1), 1, Uzn)
GoTo adım:
Else
Uzn = Uzn + 1
End If
Next a
adım:
Next x1

Range("J3:J" & sat + 2).Value = dizi1()
Application.Calculation = xlCalculationAutomatic

End Sub