Extract value into columns using VBA

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
375
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
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
375
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
Sadly format text only works on numeric values, here is a modified version.

VBA Code:
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
 

Attachments

  • Screenshot 2022-03-18 155357.jpg
    Screenshot 2022-03-18 155357.jpg
    55.6 KB · Views: 5

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
38,033
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Your last value only has 11 characters... isn't it supposed to have 12 characters?
 

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
375
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
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...
VBA Code:
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.
 

Attachments

  • 3.jpg
    3.jpg
    63.2 KB · Views: 6
  • 3.jpg
    3.jpg
    63.2 KB · Views: 4

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
375
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
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

Active Member
Joined
Mar 5, 2021
Messages
375
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
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

MrExcel MVP
Joined
Feb 23, 2021
Messages
5,013
Office Version
  1. 365
Platform
  1. Windows
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
 

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
5,013
Office Version
  1. 365
Platform
  1. Windows
I don't know what time zone you are in so I also had a go at modifying @Rick Rothstein's version:-

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

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
375
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
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
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

Active Member
Joined
Mar 5, 2021
Messages
375
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
I don't know what time zone you are in so I also had a go at modifying @Rick Rothstein's version:-

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
            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 !
 

Forum statistics

Threads
1,175,545
Messages
5,898,059
Members
434,691
Latest member
2_nisia

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
Top