Extract value into columns using VBA

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
382
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
Hi Guys,
I want to create a code to split the content of a cell into 3 colurmns but it does not work out. Please help to make it through.

onlymac.jpg

What the code should do is to convert the those numbers in the left to MAC address and put it into column B, and those numbers after "X=" and "Y=" to column C and D respectively.

Here is my unfinished code
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myText As String
Dim macText As String
Dim c As Range
Dim lrow As Long
Dim EntryMac As Long
Dim EntryX As Long
Dim EntryY As Long


lrow = Range("A1").End(xlDown).Row

If Target.CountLarge > 1 Then Exit Sub
On Error GoTo ErrHandler:


    If Len(Target) < 12 Then Exit Sub  'check for correct length
    If Target.Column <> 1 And Target.Row = 1 Then Exit Sub 'only Column A and Row 2 downwards
    If Target.Value = "" Then Exit Sub
    Application.EnableEvents = False
    
    If Not Intersect(Target, Range("A2:A" & lrow)) Is Nothing Then
    
    For Each c In Range("b2:b" & lrow)
        
         macText = Left(Target.Value, 12)
         myText = Left(macText.Value, 2) _
        & "-" & Mid(macText.Value, 3, 2) _
        & "-" & Mid(macText.Value, 5, 2) _
        & "-" & Mid(macText.Value, 7, 2) _
        & "-" & Mid(macText.Value, 9, 2) _
        & "-" & Right(macText.Value, 2)
      
    EntryMac = Left(Target, 12)
    EntryX = InStr(Target, "X=" - InStr(Target, "Y="))
    EntryY = InStr(Target, "Y=")
          c.Value = UCase(myText)
        
    
    mcell.Value = macText
    
    Next c
  
    
    Application.EnableEvents = True
End Sub
 
This works too ! This might be the simplest code to achieve the goal but I am not at the level to understand how those arrays work and of course I don't know how to add msgbox alert within. Thx !
Here is that version with a message box added.
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, rCell As Range
    Dim lrow As Long
    
    lrow = Range("A1").End(xlDown).Row
    Set rng = Intersect(Target, Range("A2:A" & lrow))
    
    If Not rng Is Nothing Then
        Application.EnableEvents = False
        rng.TextToColumns rng.Offset(, 1), xlDelimited, , 1, 0, 0, 0, 1, 1, "=", Array(Array(1, 1), Array(2, 9), Array(3, 1), Array(4, 9), Array(5, 1))
        For Each rCell In rng
            If Len(rCell.Offset(, 1)) = 12 Then
                rCell.Offset(, 1) = Format(UCase(rCell.Offset(, 1)), "@@-@@-@@-@@-@@-@@")
            Else
                MsgBox "The following Mac Address is not 12 characters long" & vbLf & _
                    "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                    "Mac Address: " & vbTab & rCell.Offset(, 1) & vbLf & _
                    "Length: " & vbTab & vbTab & Len(rCell.Offset(, 1))
            End If
        Next rCell
        Application.EnableEvents = True
    End If
End Sub
 
Upvote 0

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Give this a try:-

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lrow As Long
    Dim arr As Variant
    Dim rng As Range, rCell As Range
   
    lrow = Range("A1").End(xlDown).Row
    Set rng = Intersect(Target, Range("A2:A" & lrow))
   
    If Not rng Is Nothing Then
        Application.EnableEvents = False
        For Each rCell In rng
          
            If rCell.Value <> "" Then
                arr = Split(Application.Trim(rCell), " ")
                If Len(arr(0)) = 12 Then
                    rCell.Offset(0, 1) = Format(UCase(arr(0)), "@@-@@-@@-@@-@@-@@")
                    rCell.Offset(0, 2) = Mid(arr(1), 3, Len(arr(1)) - 2)
                    rCell.Offset(0, 3) = Mid(arr(2), 3, Len(arr(1)) - 2)
                Else
                    MsgBox "The following Mac Address is not 12 characters long" & vbLf & _
                        "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                        "Mac Address: " & vbTab & arr(0) & vbLf & _
                        "Length: " & vbTab & vbTab & Len(arr(0))
                End If
            End If
                   
        Next rCell
       
        Application.EnableEvents = True
    End If

End Sub
Hi Alex, If I want to enchance the error message about X or Y data. Can I add this code ?

VBA Code:
elseif Len(arr(1)) or Len(arr(2))="" then
MsgBox "Either or Both X Or Y Data is/are missing" & vbLf & _
                        "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                        "X Data" & vbTab & arr(1) & vbLf & _
                        "Y Data" & vbTab & arr(2)
 
Upvote 0
There are a few different possible combinations for this, see if this gives you what you need:

VBA Code:
        For Each rCell In rng

            If rCell.Value <> "" Then
                arr = Split(Application.Trim(rCell), " ")
                If Len(arr(0)) = 12 Then
                    rCell.Offset(0, 1) = Format(UCase(arr(0)), "@@-@@-@@-@@-@@-@@")
                    rCell.Offset(0, 2) = Mid(arr(1), 3, Len(arr(1)) - 2)
                    rCell.Offset(0, 3) = Mid(arr(2), 3, Len(arr(1)) - 2)
                    
                    If rCell.Offset(0, 2) = "" Or rCell.Offset(0, 3) = "" Then
                        MsgBox "Either or Both X Or Y Data is/are missing" & vbLf & _
                                            "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                                            "X Data" & vbTab & arr(1) & vbLf & _
                                            "Y Data" & vbTab & arr(2)
                    End If
                Else
                    MsgBox "The following Mac Address is not 12 characters long" & vbLf & _
                        "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                        "Mac Address: " & vbTab & arr(0) & vbLf & _
                        "Length: " & vbTab & vbTab & Len(arr(0))
                End If
                           
            End If

        Next rCell
 
Upvote 0
Hi Alex, the code not able to show error on X and Y data. See image attached.
should it be better to detect the error from the source column (A) using arr(2) and arr(3) !
 

Attachments

  • error.jpg
    error.jpg
    47.8 KB · Views: 7
Upvote 0
Hi Alex, the code not able to show error on X and Y data. See image attached.
should it be better to detect the error from the source column (A) using arr(2) and arr(3) !
I am surprised you didn't mention that it actually errored out and show the error message.
If there are less than 3 elements in the array after the split it is erroring out, so try this.

VBA Code:
        For Each rCell In rng

            If rCell.Value <> "" Then
                arr = Split(Application.Trim(rCell), " ")
                If Len(arr(0)) = 12 Then
                    rCell.Offset(0, 1) = Format(UCase(arr(0)), "@@-@@-@@-@@-@@-@@")
                    If UBound(arr) > 0 Then rCell.Offset(0, 2) = Mid(arr(1), 3, Application.Max(0, Len(arr(1)) - 2))
                    If UBound(arr) > 1 Then rCell.Offset(0, 3) = Mid(arr(2), 3, Application.Max(0, Len(arr(2)) - 2))
                    
                    If rCell.Offset(0, 2) = "" Or rCell.Offset(0, 3) = "" Then
                        MsgBox "Either or Both X Or Y Data is/are missing" & vbLf & _
                                            "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                                            "X Data" & vbTab & rCell.Offset(0, 2) & vbLf & _
                                            "Y Data" & vbTab & rCell.Offset(0, 3)
                    End If
                Else
                    MsgBox "The following Mac Address is not 12 characters long" & vbLf & _
                        "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                        "Mac Address: " & vbTab & arr(0) & vbLf & _
                        "Length: " & vbTab & vbTab & Len(arr(0))
                End If            
            End If

        Next rCell
 
Upvote 0
Even using Excels own Text to Columns will do this straight off
 
Upvote 0
Hi Alex, the code mixed up the position of "Y=" data if "X=" data is missing. See the last row of the image.
 

Attachments

  • error0404.jpg
    error0404.jpg
    147.4 KB · Views: 4
Upvote 0
I am probably making a bit of a meal of this but this should do what you are after:
VBA Code:
' Works at this point my version
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lrow As Long
    Dim arr As Variant
    Dim rng As Range, rCell As Range

    lrow = Range("A1").End(xlDown).Row
    Set rng = Intersect(Target, Range("A2:A" & lrow))

    If Not rng Is Nothing Then
        Application.EnableEvents = False
        For Each rCell In rng

            If rCell.Value <> "" Then
                arr = Split(Application.Trim(rCell), " ")
                If Len(arr(0)) = 12 Then
                    rCell.Offset(0, 1) = Format(UCase(arr(0)), "@@-@@-@@-@@-@@-@@")
                    If UBound(arr) > 1 Then
                        rCell.Offset(0, 2) = Mid(arr(1), 3, Application.Max(0, Len(arr(1)) - 2))
                        rCell.Offset(0, 3) = Mid(arr(2), 3, Application.Max(0, Len(arr(2)) - 2))
                    Else
                        If UBound(arr) > 0 And Left(arr(1), 1) = "X" Then
                            rCell.Offset(0, 2) = Mid(arr(1), 3, Application.Max(0, Len(arr(1)) - 2))
                        Else
                            rCell.Offset(0, 3) = Mid(arr(1), 3, Application.Max(0, Len(arr(1)) - 2))
                        End If
                    End If
                    
                    If rCell.Offset(0, 2) = "" Or rCell.Offset(0, 3) = "" Then
                        MsgBox "Either or Both X Or Y Data is/are missing" & vbLf & _
                                            "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                                            "X Data" & vbTab & rCell.Offset(0, 2) & vbLf & _
                                            "Y Data" & vbTab & rCell.Offset(0, 3)
                    End If
                Else
                    MsgBox "The following Mac Address is not 12 characters long" & vbLf & _
                        "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                        "Mac Address: " & vbTab & arr(0) & vbLf & _
                        "Length: " & vbTab & vbTab & Len(arr(0))
                End If
            
            End If

        Next rCell

        Application.EnableEvents = True
    End If

End Sub
 
Upvote 0
Hi Alex, the new code seems to have minor bug or missing one more condition clause.
I tried to add "On error resume next" then no error prompt up !!
 

Attachments

  • a.png
    a.png
    8.4 KB · Views: 5
  • b.png
    b.png
    4 KB · Views: 3
Upvote 0
Hi Alex, the new code seems to have minor bug or missing one more condition clause.
I tried to add "On error resume next" then no error prompt up !!
Try this
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lrow As Long
    Dim arr As Variant
    Dim rng As Range, rCell As Range

    lrow = Range("A1").End(xlDown).Row
    Set rng = Intersect(Target, Range("A2:A" & lrow))

    If Not rng Is Nothing Then
        Application.EnableEvents = False
        For Each rCell In rng

            If rCell.Value <> "" Then
                arr = Split(Application.Trim(rCell), " ")
                If Len(arr(0)) = 12 Then
                    rCell.Offset(0, 1) = Format(UCase(arr(0)), "@@-@@-@@-@@-@@-@@")
                    If UBound(arr) > 1 Then
                        rCell.Offset(0, 2) = Mid(arr(1), 3, Application.Max(0, Len(arr(1)) - 2))
                        rCell.Offset(0, 3) = Mid(arr(2), 3, Application.Max(0, Len(arr(2)) - 2))
                    Else
                        If UBound(arr) > 0 Then
                            If Left(arr(1), 1) = "X" Then
                                rCell.Offset(0, 2) = Mid(arr(1), 3, Application.Max(0, Len(arr(1)) - 2))
                            Else
                                rCell.Offset(0, 3) = Mid(arr(1), 3, Application.Max(0, Len(arr(1)) - 2))
                            End If
                        End If
                    End If
                    
                    If rCell.Offset(0, 2) = "" Or rCell.Offset(0, 3) = "" Then
                        MsgBox "Either or Both X Or Y Data is/are missing" & vbLf & _
                                            "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                                            "X Data" & vbTab & rCell.Offset(0, 2) & vbLf & _
                                            "Y Data" & vbTab & rCell.Offset(0, 3)
                    End If
                Else
                    MsgBox "The following Mac Address is not 12 characters long" & vbLf & _
                        "Cell: " & vbTab & vbTab & rCell.Address & vbLf & _
                        "Mac Address: " & vbTab & arr(0) & vbLf & _
                        "Length: " & vbTab & vbTab & Len(arr(0))
                End If            
            End If

        Next rCell

        Application.EnableEvents = True
    End If

End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,213,497
Messages
6,113,998
Members
448,539
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top