Satırdaki rakamları ayırma

[denizfatihi]

Herkese Merhaba,

Yapmak demek açıklama olay açıklamasında yer alan 14.94x125 kısım 2 sutuna sınırlaması.
yardım ve ilginiz için teşekkür ederim.

Kolay gelsin,

açıklama birim adet 18/01/2023 Ref = 003BOW HA 14.94x125 VESBE 14,94​ 125​ 18/01/2023 Ref = 003JD4 HA 43,16x100 SISE 43,16​ 100​ 18/01/2023 Ref = 003MDN HA 307.80x5 GUBRF 307,8​ 5​

 

[hasankardas]

Metni sütunlara dönüştür ile yapabilirsiniz.

 

[denizfatihi]

teşekkür ederim, o benimde aklıma gelmişti ama satırda çok girinti ve çıkıntı var denk gelmiyor o yüzden olmadı.

 

[veyselemre]

Sub test()
    Dim rng As Range, i, m As Object
    Set rng = Range("B4:D" & Cells(Rows.Count, 2).End(3).Row)
    With CreateObject("VBScript.RegExp")
        .Pattern = "([\d\.\,]+)x(\d+)"
        For i = 1 To rng.Rows.Count
            Set m = .Execute(rng(i, 1).Value)(0).submatches
            rng(i, 2).Resize(, 2).Value = Array(m(0), m(1))
        Next i
    End With
End Sub

 

[denizfatihi]

Sub test()
    Dim rng As Range, i, m As Object
    Set rng = Range("B4:D" & Cells(Rows.Count, 2).End(3).Row)
    With CreateObject("VBScript.RegExp")
        .Pattern = "([\d\.\,]+)x(\d+)"
        For i = 1 To rng.Rows.Count
            Set m = .Execute(rng(i, 1).Value)(0).submatches
            rng(i, 2).Resize(, 2).Value = Array(m(0), m(1))
        Next i
    End With
End Sub

Sayın veyselemre merhaba,

Aşağıdaki hatayı alıyorum, ekstra yapmam gereken bir ayar mı var ?
hala office 2010 kullanıyorum.

---------------------------
Microsoft Visual Basic for Applications
---------------------------
Run-time error '5':

Invalid procedure call or argument
---------------------------
Tamam Yardım
---------------------------

 

[denizfatihi]

Adım adım takip ettikten sonra aşağıdaki satırda hata verdiğini fark ettim.

Set m = .Execute(rng(i, 1).Value)(0).submatches

 

[Greenblacksea53]

C4 hücresine =PARÇAAL(B4;MBUL("HA";B4;1)+3;MBUL("x";B4;1)-MBUL("HA";B4;1)-3)
D4 hücresine=PARÇAAL(B4;MBUL("x";B4;1)+1;BUL(" ";B4;MBUL("x";B4;1)+1)-MBUL("x";B4;1))

Yazıp dener misiniz ?

 

[denizfatihi]

Sayın Greenblacksea53 Merhaba,

Öncelikle teşekkür ederim, parça alımında işe yarıyor yanlız (birim * adet) kısmı yapmam gerektiği için nokta ve virgül farklı sonuçlar veriyor.

 

[Korhan Ayhan]

Merhaba,

Eğer kontrol edilen hücre aralığında boş hücre ya da koşula uymayan yapıda hücre varsa hata verebilir.

veyselemre beyin önerisini aşağıdaki gibi değiştirip kullanabilirsiniz.

Option Explicit

Sub test()
    Dim rng As Range, i, m As Object
    
    Range("C4:D" & Rows.Count).ClearContents
    
    Set rng = Range("B4:D" & Cells(Rows.Count, 2).End(3).Row)
    
    With CreateObject("VBScript.RegExp")
        .Pattern = "([\d\.\,]+)x(\d+)"
        For i = 1 To rng.Rows.Count
            If .test(rng(i, 1).Value) Then
                Set m = .Execute(rng(i, 1).Value)(0).submatches
                rng(i, 2).Resize(, 2).Value = Array(m(0), m(1))
            End If
        Next i
    End With

    MsgBox "İşleminiz tamamlanmıştır."
End Sub

 

[denizfatihi]

Korhan Bey çok teşekkür ederim, tam istediğim gibi oldu,
yardımcı olan ve fikir veren herkese de ayrıca teşekkür ederim.

iyi günler dilerim...