Bir cümlede bulunan rakamları ayrı hücrelere yazdırmak

[serdarkurdal]

İyi günler, forumda arama yaptım lakin tam çözümü bulamadım
Ekte bulunan dosyada stok isimlerinin içinde ilgili stoğun boyutları mevcut
Bazı stoklarımın tek boyut bilgisi varken, bazılarının iki, bazılarının üç boyut bilgisi mevcut
belli bir standart yok maalesef
Benim istediğim (mümkünse bir makro ile) boyut bilgilerinin her birinin ayrı hücrelere gelmesi

Şimdiden teşekkür ederim

 

[Necdet]

Merhaba,

Farklı yöntemler olabilir, aşağıdaki kodları dener misiniz?

Sub BoyutBul()

    Dim i   As Long, _
        j   As Integer, _
        d   As Variant, _
        e   As String
    
    Application.ScreenUpdating = False
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        e = Replace(Cells(i, "A"), "Ø", "")
        j = InStr(e, " mm")
        If j > 0 Then
            d = Split(Left(e, j - 1), "*")
            Range("B" & i).Resize(1, UBound(d) + 1) = d
        End If
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır..."
    
End Sub

 

[serdarkurdal]

Çok teşekkürler Elleriniz dert görmesin inşallah....

 

[1ndependent]

Merhaba,

Farklı yöntemler olabilir, aşağıdaki kodları dener misiniz?

Sub BoyutBul()

    Dim i   As Long, _
        j   As Integer, _
        d   As Variant, _
        e   As String
   
    Application.ScreenUpdating = False
   
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        e = Replace(Cells(i, "A"), "Ø", "")
        j = InStr(e, " mm")
        If j > 0 Then
            d = Split(Left(e, j - 1), "*")
            Range("B" & i).Resize(1, UBound(d) + 1) = d
        End If
    Next i
   
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır..."
   
End Sub

Necdet bey merhaba,

Vermiş olduğunuz kodun direk çalışması için ne şekilde bir değişiklik yapmamız gerekli?
Hücrelere değerleri girmiş olduğumuzda a,b,c hücresine değerler kendiliğinden gelmesi için?

 

[Necdet]

Necdet bey merhaba,

Vermiş olduğunuz kodun direk çalışması için ne şekilde bir değişiklik yapmamız gerekli?
Hücrelere değerleri girmiş olduğumuzda a,b,c hücresine değerler kendiliğinden gelmesi için?

Merhaba,

Verilerin aynı mantıkla yazıldığını varsayarsak, aşağıdaki kodlar

Private Sub Worksheet_Change(ByVal Target As Range)

    If Intersect(Target, [A:A]) Is Nothing Or Target.Row < 2 Then Exit Sub
    
    Dim i   As Long, _
        j   As Integer, _
        d   As Variant, _
        e   As String
    
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        e = Replace(Target.Value, "Ø", "")
        j = InStr(e, " mm")
        If j > 0 Then
            d = Split(Left(e, j - 1), "*")
            Target.Offset(0, 1).Resize(1, UBound(d) + 1) = d
        End If
    Next i
    
End Sub

ilgili sayfanın kod bölümünde olmalı.

 

[Necdet]

Çok teşekkürler Elleriniz dert görmesin inşallah....

Güle güle kullanınız, kolay gelsin.