Extract value into columns using VBA

[Vincent88]

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.

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

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

 

[Alex Blakenburg]

Ahh I was to quick to write off my initial submission. All I had to do was change it to
Target.Offset(0, 1) = Format(arr(0), "@@-@@-@@-@@-@@-@@")
Thanks @Rick Rothstein

 

[Vincent88]

Sadly format text only works on numeric values, here is a modified version.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim macText As String
    Dim lrow As Long
    Dim arr As Variant
    Dim i As Long

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

    If Target.CountLarge > 1 Then Exit Sub

'   If update is to column A after row 2
    If Target.Column = 1 And Target.Row > 1 Then

        Application.EnableEvents = False

        arr = Split(Application.Trim(Target), " ")

        macText = ""
        For i = 1 To 11 Step 2
            macText = macText & "-" & Mid(arr(0), i, 2)
        Next i

        Target.Offset(0, 1) = Right(UCase(macText), Len(macText) - 1)
        Target.Offset(0, 2) = Mid(arr(1), 3, Len(arr(1)) - 2)
        Target.Offset(0, 3) = Mid(arr(2), 3, Len(arr(1)) - 2)

[/QUOTE]

Hi Alex, this works but I want to add a warning that if the MAC address is less than 12 characters then a warning prompt and function stops.
I changed below code after next i but in vain. 



[CODE]If Len(macText) < 12 Then
           MsgBox "InAppropriate MAC Address"
        Else
        Target.Offset(0, 1) = Right(UCase(macText), Len(macText) - 1)
        Target.Offset(0, 2) = Mid(arr(1), 3, Len(arr(1)) - 2)
        Target.Offset(0, 3) = Mid(arr(2), 3, Len(arr(1)) - 2)
        End If

 

[Rick Rothstein]

Your last value only has 11 characters... isn't it supposed to have 12 characters?

 

[Vincent88]

Oh, MAC addresses have dashes in them! I wasn't aware of that. Okay, here is my previously posted event code procedure modified to do that...

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = 1 And Target.Row > 1 Then
    Target.TextToColumns Target.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))
    Target.Offset(, 1) = Format(Target.Offset(, 1), "@@-@@-@@-@@-@@-@@")
  End If
End Sub

Hi Rick,
Your code works on input data manually in column A but in reality I copy & paste data to it and it shows error.

 

[Vincent88]

Your last value only has 11 characters... isn't it supposed to have 12 characters?

Hi Rick,
I intended to do it cos I am asking Alex to help in creating an error msgbox pop up if this happens. I added the msgbox code in comment 12 but not work.

 

[Vincent88]

Hi Alex & Rick,
In reality I copy multi data rows to column A, but the worksheet_change mode only works on the first row and I have to move the cursor the next row and click enter to make the splits. What suggestions you may have if I want all rows with pasted data to make the splits effectively by just making one click !
May be making it as regular module and assign a shortcut key to implement the task in one shot ?

 

[Alex Blakenburg]

Give this a try:-

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

 

[Alex Blakenburg]

I don't know what time zone you are in so I also had a go at modifying @Rick Rothstein's version:-

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
            rCell.Offset(, 1) = Format(UCase(rCell.Offset(, 1)), "@@-@@-@@-@@-@@-@@")
        Next rCell
        Application.EnableEvents = True
    End If
End Sub

 

[Vincent88]

Give this a try:-

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

This works exactly what I want. I was worried even with the msgbox alert but without indication where went wrong, it was not perfect. Now you help me to clear all hurdles. Thx.

 

[Vincent88]

I don't know what time zone you are in so I also had a go at modifying @Rick Rothstein's version:-

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
            rCell.Offset(, 1) = Format(UCase(rCell.Offset(, 1)), "@@-@@-@@-@@-@@-@@")
        Next rCell
        Application.EnableEvents = True
    End If
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 !