Hücredeki veriyi diğer hücrelere ayırarak aktarmak

[1Al2Ver]

Merhaba,

Ek'li dosyada Modül1'de kayıtlı macro, A1'den itibaren kayıtlı olan verilerden, rakam olanları alıp, B1'den itibaren sıralamaktadır, yani karşısına yazmaktadır.

İstenen ise; A2 den itibaren ( A2:A) kayıt edilen verileri cinsi, miktarı ve birimine göre B2 (B2:B) ve C2 (C2:C) den itibaren sıralatmaktır.

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

Veri--Metni Sütunlara Dönüştür , uygulaması ile istediğime ulaşamadım, malum hücredeki veriyi boşlukları dikkate alarak sütunlara ayırıyor, dolayısıyla Veri--Metni Sütunlara Dönüştür ile tam istediğim çözüm olamadı.

Mevcut kodda değişiklik mi gerekiyor, yoksa kod yeniden mi yazılmalı ?

Kodda olası değişiklikleri veya yeni kod gerekli ise kodu rica ediyorum,

Saygılarımla

 

[BG]

sayın 1Al2Ver

soyle birsey mi ? dogru mu anladim acaba?
dosyanız ektedir.

 

[1Al2Ver]

soyle birsey mi ? dogru mu anladim acaba?
dosyanız ektedir.

Sayın brain, merhaba

A sütununda sadece malzemenin adı kalacak ( Çilek Reçeli ) diğer sütunlar için sorun yok

İlginiz için teşekkür ederim

 

[1Al2Ver]

Projenin ; A sütununda sadece malzemenin adı kalacak ( Örn ; Çilek Reçeli ) diğer sütunlar için sayın Brain'in çözümüne sorun yok

ilgilenen arkadaşlara teşekkür ederim,

 

[abdi]

Sub RakamAl()
Dim birim As String
Columns("B").ClearContents
For i = 1 To [A65536].End(3).Row
    metin = Cells(i, "A")
    sayı = ""
   
    For j = 1 To Len(metin)
        Karakter = Mid(metin, j, 1)
         birim = Right(metin, 2)
        If IsNumeric(Karakter) = True Or Karakter = "." Or Karakter = "," Then
            sayı = sayı & Karakter
        End If
    Next j
    
    Cells(i, "A") = Mid(metin, 1, (Len(metin) - Len(sayı + birim) - 2)) ', (Len(metin) - Len(sayı + birim)))
    Cells(i, "B") = sayı + 0
    Cells(i, "c") = birim
Next i
End Sub

kodu bu şekilde denermisiniz.

iyi akşamlar

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki kodu denermisiniz.

Sub RAKAM_AYIR()
    Columns("B:C").ClearContents
    For X = 1 To [A65536].End(3).Row
    If InStr(1, Cells(X, 1), " ") > 0 Then
    Veri = Split(Cells(X, 1), " ")
    For Y = 1 To UBound(Veri)
    If IsNumeric(Veri(Y)) Then
    Cells(X, 2) = Veri(Y) * 1
    Cells(X, 3) = Veri(UBound(Veri))
    Cells(X, 1) = Mid(Cells(X, 1), 1, WorksheetFunction.Find(Cells(X, 2), Cells(X, 1), 1) - 2)
    End If
    Next
    End If
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[1Al2Ver]

Sub RakamAl()
Dim birim As String
Columns("B").ClearContents
For i = 1 To [A65536].End(3).Row
    metin = Cells(i, "A")
    sayı = ""
   
    For j = 1 To Len(metin)
        Karakter = Mid(metin, j, 1)
         birim = Right(metin, 2)
        If IsNumeric(Karakter) = True Or Karakter = "." Or Karakter = "," Then
            sayı = sayı & Karakter
        End If
    Next j
    
    Cells(i, "A") = Mid(metin, 1, (Len(metin) - Len(sayı + birim) - 2)) ', (Len(metin) - Len(sayı + birim)))
    Cells(i, "B") = sayı + 0
    Cells(i, "c") = birim
Next i
End Sub

kodu bu şekilde denermisiniz.

iyi akşamlar

Sayın abdi, merhaba, çözüm ve ilginiz için teşekkür ederim, saygılarımla

 

[1Al2Ver]

Selamlar,

Alternatif olarak aşağıdaki kodu denermisiniz.

Sub RAKAM_AYIR()
    Columns("B:C").ClearContents
    For X = 1 To [A65536].End(3).Row
    If InStr(1, Cells(X, 1), " ") > 0 Then
    Veri = Split(Cells(X, 1), " ")
    For Y = 1 To UBound(Veri)
    If IsNumeric(Veri(Y)) Then
    Cells(X, 2) = Veri(Y) * 1
    Cells(X, 3) = Veri(UBound(Veri))
    Cells(X, 1) = Mid(Cells(X, 1), 1, WorksheetFunction.Find(Cells(X, 2), Cells(X, 1), 1) - 2)
    End If
    Next
    End If
    Next
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sayın Korhan Ayhan, merhaba, kod çalışıyor, sorun yok, size de ilginiz ve çözümünüz için teşekkür ederim, saygılarımla.

 

[abdi]

sayın 1Al2Ver
işinize yaradığına sevindim iyi çalışmalar dilerim.