Data pull in Specific Format

[Abhijeet]

Hi
I have Data in excel please help me and give macro for this
Assignment REMARKS
123 3XA
123-2 2XA 1XC 2XD
from this data i want in this format
Assignment REMARKS Value 1 Value 2
123 3XA A 3
123-2 2XA A 2
123-2 1XC C 1
123-2 2XD D 2

 

[Somendra Misra]

Hi Abhijeet,

See the file.

Regards,

 

[Abhijeet]

Somendra this is work but any value 6.5 or like that then that not pull 6.5 pull 5 can please look this

 

[Deepak]

Check this..

Sub export()
Dim last As Long, lrng As Range, r As Range
Dim arng As Range, l As Single, i As Single, v As String

last = Cells(Rows.Count, 2).End(xlUp).Row
Set lrng = Range("B2:B" & last)

For Each r In lrng
    v = Replace(r.Value, " ", "")
    l = Len(v) - 2
    For i = 1 To l Step 3
        Set arng = Cells(Rows.Count, 6).End(xlUp)(2)
            arng.Value = r.Offset(0, -1).Value
            arng.Offset(0, 1).Value = Mid(v, i, 3)
            arng.Offset(0, 2).Value = Mid(v, i + 2, 1)
            arng.Offset(0, 3).Value = Mid(v, i, 1)
    Next
Next
Set arng = Nothing
Set lrng = Nothing
End Sub

 

[Abhijeet]

No this is also get same result its also not work for point values

 

[Somendra Misra]

@Abhijeet

Can you tell what your data exactly look like? Give just 5 sample

Regards,

 

[Abhijeet]

ur File given is fine only If Value in 6.5XA then not give 6.5 value macro give 6 & one more thing if XA6.5 this kind of value then also not work

 

[Abhijeet]

Mostly my data is Numbers are in staring then Code XA ..... like that

 

[Somendra Misra]

See the file.

Regards,

 

[Abhijeet]

Thanks Somendra its work properly

 

[Deepak]

Check!!

Sub export()
Dim last As Long, lrng As Range, r As Range
Dim arng As Range, l As Single, i As Single, v As Variant

last = Cells(Rows.Count, 2).End(xlUp).Row
Set lrng = Range("B2:B" & last)

For Each r In lrng
    v = Split(r.Value, "  ")
    For i = LBound(v) To UBound(v)
        Set arng = Cells(Rows.Count, 6).End(xlUp)(2)
            arng.Value = r.Offset(0, -1).Value
            arng.Offset(0, 1).Value = v(i) 'Mid(v(i), i, 3)
            arng.Offset(0, 2).Value = Right(v(i), 1) 'Mid(v(i), i + 2, 1)
            arng.Offset(0, 3).Value = Left(v(i), InStr(v(i), "X") - 1) 'Mid(v(i), i, 1)
    Next
   
Next
Set arng = Nothing
Set lrng = Nothing
End Sub

 

[Abhijeet]

After run the macro only this value give wrong
124 2XA 1XD D 2

 

[Abhijeet]

Hi Deepak
In attach file Ur macro with Data in Red color i highlighted wrong data

 

[Deepak]

Hi,

This issue occurred as 2XA<>1XD<>1XC having single space between 2XA<>1XD

v = Split(r.Value, "  ")

it should be like as 2XA<><>1XD<><>1XC ; because others are in the same format meanwhile later, i will look for a dynamic approach for the same.

 

[Deepak]

Check this.

Sub export2()
Dim last As Long, lrng As Range, r As Range, m As Single
Dim arng As Range, l As Single, i As Single, v As Variant

last = Cells(Rows.Count, 2).End(xlUp).Row
Set lrng = Range("B2:B" & last)

For Each r In lrng
    v = Split(Application.Trim(r.Value), " ")
    For i = LBound(v) To UBound(v)
        Set arng = Cells(Rows.Count, 6).End(xlUp)(2)
            arng.Value = r.Offset(0, -1).Value
            If Not Len(v(i)) = 3 Then
                arng.Offset(0, 1).Value = ""
            Else
                arng.Offset(0, 1).Value = v(i)
            End If
           
            If Not IsNumeric(Right(v(i), 1)) Then
                arng.Offset(0, 2).Value = Right(v(i), 1)
            Else
                arng.Offset(0, 2).Value = ""
            End If
           
            m = InStr(v(i), "X")
           
            If Not m > 0 Then
                 If Not IsNumeric(v(i)) Then
                    arng.Offset(0, 3).Value = ""
                Else
                    arng.Offset(0, 3).Value = v(i)
                End If
            Else
                arng.Offset(0, 3).Value = Left(v(i), InStr(v(i), "X") - 1)
            End If
   Next
Next
Set arng = Nothing
Set lrng = Nothing
End Sub