sutundaki sayıları ve yazıları ayırma

[seckinsrt]

merhaba benim ihtiyacım olan program bir sütundaki sayıları olan satırları kopyalayıp b hucresine yapıştıran, yazıları ise C hücresine yapıştıran programa ihtiyacım var. yardımcı olursanız çok sevinirim.

 

[antonio]

Harf ve rakamların karışık bir şekilde Çalışma kitabınızın A sütununa yazıldığı varsayımı ile aşağıda ki kodlar ile harfleri B sütununa, rakamları da C sütununa yazdırabilirsiniz:

Sub HARF_RAKAM_AYIR()
Dim sh As Worksheet, hc As Range, ss As Integer
Set sh = ThisWorkbook.ActiveSheet
ss = sh.Range("A:D").Find("*", , , , xlByRows, xlPrevious).Row
For i = 2 To ss
    Set hc = sh.Range("A" & i)
    
    For d = 1 To Len(hc.Value)
        If IsNumeric(Mid(hc.Value, d, 1)) = False Then
            harf = harf & Mid(hc.Value, d, 1)
        End If
        If IsNumeric(Mid(hc.Value, d, 1)) = True Then
            rakam = rakam & Mid(hc.Value, d, 1)
            
        End If
    Next d
    hc.Offset(0, 1).Value = harf
    Columns("C").NumberFormat = "@"
    hc.Offset(0, 2).Value = rakam
    harf = ""
    rakam = ""
Next i
MsgBox "işlem tamam", vbInformation, "işlem sonucu"
End Sub

 

[systran]

@antonio; müsadenle yazdığın kodu değiştirdim.

Dim sh As Worksheet, hc As Range, ss As Integer
Set sh = ThisWorkbook.ActiveSheet
ss = sh.Range("A:D").Find("*", , , , xlByRows, xlPrevious).Row
Dim ptr_1 As Integer
Dim ptr_2 As Integer
ptr_1 = 1
ptr_2 = 1
For i = 1 To ss
    Set hc = sh.Range("A" & i)
    
    If IsNumeric(hc.Value) Then
        Sayfa1.Range("B" & ptr_1).Value = hc.Value
        ptr_1 = ptr_1 + 1
    Else
        Sayfa1.Range("C" & ptr_2).Value = hc.Value
        ptr_2 = ptr_2 + 1
    End If
Next i
MsgBox "işlem tamam", vbInformation, "işlem sonucu"

 

[systran]

@antonio; müsadenle yazdığın kodu değiştirdim.

Dim sh As Worksheet, hc As Range, ss As Integer
Set sh = ThisWorkbook.ActiveSheet
ss = sh.Range("A:D").Find("*", , , , xlByRows, xlPrevious).Row
Dim ptr_1 As Integer
Dim ptr_2 As Integer
ptr_1 = 1
ptr_2 = 1
For i = 1 To ss
    Set hc = sh.Range("A" & i)
    
    If IsNumeric(hc.Value) Then
        Sayfa1.Range("B" & ptr_1).Value = hc.Value
        ptr_1 = ptr_1 + 1
    Else
        Sayfa1.Range("C" & ptr_2).Value = hc.Value
        ptr_2 = ptr_2 + 1
    End If
Next i
MsgBox "işlem tamam", vbInformation, "işlem sonucu"