rakam ve alfabeden oluşan hücreyi belli bir düzende ayırma

[ridvansahin]

A sütunundaki gibi görünen alfabe ve rakam karmaşasını aşağıda gösterdiğim düzende ayrımak istiyorum. Bunun bir fonksiyonu yazılabilir mi.?

Saygılar.

540K480	540	K	480
AB22C14	AB	22	C	14
75ASD13B	75	ASD	13	B

 

[beab05]

Aşağıdaki kodla yapabilirsiniz. A1 den almaya başlar ve B1 itibaren ayırır. Siz kodda değişiklikle istediğiniz gibi kullanırsınız. ChatGPT ye de selamlarımızı yolluyoruz.

Sub AyirHarfRakam()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim cellValue As String
    Dim currentColumn As Integer
    Dim previousCharType As String
    Dim charType As String
    
  
    Set ws = ThisWorkbook.ActiveSheet
    
  
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
  
    For i = 1 To lastRow
        ' Satırdaki hücre değerini al
        cellValue = ws.Cells(i, 1).Value
        
        ' İlk sütundan başlayarak harfleri ve rakamları sırasıyla ayırıp diğer sütunlara yaz
        currentColumn = 2 ' B sütunundan başlar (harfler için)
        For charIndex = 1 To Len(cellValue)
            ' Karakter tipini belirle (harf mi, rakam mı?)
            If IsNumeric(Mid(cellValue, charIndex, 1)) Then
                charType = "Numeric"
            Else
                charType = "Letter"
            End If
            
            ' Eğer karakter tipi önceki karakter tipiyle aynı değilse veya bu ilk karakter ise yeni bir grup oluştur
            If charType <> previousCharType Or charIndex = 1 Then
                ws.Cells(i, currentColumn).Value = Mid(cellValue, charIndex, 1)
                currentColumn = currentColumn + 1
            Else
                ' Aynı grup ise mevcut sütuna ekle
                ws.Cells(i, currentColumn - 1).Value = ws.Cells(i, currentColumn - 1).Value & Mid(cellValue, charIndex, 1)
            End If
            
            ' Önceki karakter tipini güncelle
            previousCharType = charType
        Next charIndex
    Next i
End Sub

 

[veyselemre]

Sub test()
    Range("B:Z").ClearContents
    Dim huc As Range, m As Object, sut
    With CreateObject("VBScript.RegExp")
        .Pattern = "[\d]+|[^\d]+"
        .Global = True
        For Each huc In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
            If .test(huc.Value) Then
                sut = 2
                For Each m In .Execute(huc.Value)
                    Cells(huc.Row, sut).Value = m.Value
                    sut = sut + 1
                Next m
            End If
        Next huc
    End With
End Sub

Sub test2()
    Range("B:Z").ClearContents
    Dim huc As Range, sut&, i&, numeric As Boolean, a, b, al
    For Each huc In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
        If huc.Value <> "" Then
            sut = 2
            b = Left(huc.Value, 1)
            numeric = IsNumeric(b)
            For i = 2 To Len(huc.Value)
                a = Mid(huc.Value, i, 1)
                If numeric = IsNumeric(a) Then
                    b = b & a
                Else
                    numeric = IsNumeric(a)
                    Cells(huc.Row, sut).Value = b
                    i = i - 1
                    sut = sut + 1
                    b = ""
                End If
            Next i
            Cells(huc.Row, sut).Value = b
        End If
    Next huc
End Sub

Sub test3()
    Range("B:Z").ClearContents
    Dim huc As Range, say&, i&, numeric As Boolean, a, al
    With CreateObject("Scripting.Dictionary")
        For Each huc In Range("A1:A" & Cells(Rows.Count, 1).End(3).Row)
            al = huc.Value
            If al <> "" Then
                .RemoveAll
                say = 1
                a = Left(al, 1)
                .Item(say) = a
                numeric = IsNumeric(a)
                For i = 2 To Len(al)
                    a = Mid(al, i, 1)
                    If numeric <> IsNumeric(a) Then
                        numeric = Not numeric
                        say = say + 1
                    End If
                    .Item(say) = .Item(say) & a
                Next i
                Cells(huc.Row, 2).Resize(, say).Value = .items
            End If
        Next huc
    End With
End Sub

 

[ridvansahin]

Şimdi deneme fırsatım oldu. @beab05 çat diye oldu. @veyselemre . İkinize de çok teşekkür ederim.
Saygılar