• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA to split fullname to first and last and clean any trailing spaces

IKHAN

Member
Excel wizards need macro help on splitting fullname to seperate columns (Firstname and lastname) from (2. planning) tab and copied to (4. mobile) tab in column D and F from line 18, Need to clean any trailing spaces,If name seperated by semicolon,second name to be copied in next row and Delete last row if duplicate first and last name found (in attached ex. line 28) and update (4. mobile)tab automatically as data full name is entered in (2. planning) tab or selected from drop down list.

Can this be done in vba?
 

Attachments

  • Test.xlsx
    13.9 KB · Views: 16
Right click on the 2nd Sheet tab and choose option view code. Test this on a backup. It will run only when you make changes to column C on sheet 2. It is basic logic, edit where you need to.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objDict As Object
Dim varData, rowData, varKey
Dim varOut()
Dim i As Long

Application.EnableEvents = False

If Target.Column = 3 Then
    On Error GoTo EoSub '// Just in case something fails
    Sheets("4. Mobile").Range("D18").CurrentRegion.ClearContents
    varData = Sheets("2. Planning").Range("C2:C" & Sheets("2. Planning").Range("C" & Rows.Count).End(xlUp).Row).Value
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.Comparemode = vbTextCompare
    For i = LBound(varData) To UBound(varData)
        rowData = Split(varData(i, 1), ";")
        For j = LBound(rowData) To UBound(rowData)
            If Not objDict.exists(Application.Trim(rowData(j))) Then
                objDict.Add Application.Trim(rowData(j)), Trim(rowData(j))
            End If
        Next j
    Next i
    ReDim varOut(objDict.Count - 1, 0 To 1)
    i = 0
    For Each varKey In objDict.keys
        varOut(i, 0) = Split(varKey, " ")(0)
        varOut(i, 1) = Split(varKey, " ")(1)
        i = i + 1
    Next
    Sheets("4. Mobile").Range("D18").Resize(UBound(varOut) + 1, 2).Value = varOut
End If

EoSub:
Application.EnableEvents = True

End Sub
 
Right click on the 2nd Sheet tab and choose option view code. Test this on a backup. It will run only when you make changes to column C on sheet 2. It is basic logic, edit where you need to.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objDict As Object
Dim varData, rowData, varKey
Dim varOut()
Dim i As Long

Application.EnableEvents = False

If Target.Column = 3 Then
    On Error GoTo EoSub '// Just in case something fails
    Sheets("4. Mobile").Range("D18").CurrentRegion.ClearContents
    varData = Sheets("2. Planning").Range("C2:C" & Sheets("2. Planning").Range("C" & Rows.Count).End(xlUp).Row).Value
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.Comparemode = vbTextCompare
    For i = LBound(varData) To UBound(varData)
        rowData = Split(varData(i, 1), ";")
        For j = LBound(rowData) To UBound(rowData)
            If Not objDict.exists(Application.Trim(rowData(j))) Then
                objDict.Add Application.Trim(rowData(j)), Trim(rowData(j))
            End If
        Next j
    Next i
    ReDim varOut(objDict.Count - 1, 0 To 1)
    i = 0
    For Each varKey In objDict.keys
        varOut(i, 0) = Split(varKey, " ")(0)
        varOut(i, 1) = Split(varKey, " ")(1)
        i = i + 1
    Next
    Sheets("4. Mobile").Range("D18").Resize(UBound(varOut) + 1, 2).Value = varOut
End If

EoSub:
Application.EnableEvents = True

End Sub

It works on my backup sheet..

Having problem with my orginal sheet.

Running another code on (2. Planning) tab for to select mutiple items from dropdown list in column C (see below code)

Getting error message ambigous name



Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then

Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If oldVal = "" Then
  
  Else
  If newVal = "" Then
  
  Else
  Target.Value = oldVal & "; " & newVal

  End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub
MOD Edit: Code Tags Added.
 
Last edited by a moderator:
You'd need to combine 2 codes in same Worksheet_Change event.

As you can have only one Worksheet_Change event.
 
Just copy and paste Shrivallabha's code below existing one (I'd move Dims to top though) and test.

However, there may be some conflict, but hard to trouble shoot without having your set up. It'd help if you upload sample setup with data validation etc.
 
1) To ThisWorkbook code module
Code:
Private Sub Workbook_Open()
    Run Sheets("4. mobile").CodeName & ".worksheet_activate"
End Sub
2) To "4. Mobile" sheet code module
Code:
Private Sub Worksheet_Activate()
    Dim a, i As Long, e
    Application.EnableEvents = False
    a = Sheets("2. Planning").Columns("c").SpecialCells(2).Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            a(i, 1) = Application.Trim(a(i, 1))
            If a(i, 1) <> "" Then
                For Each e In Split(a(i, 1), ";")
                    .Item(Trim$(e)) = Split(Application.Trim(e))
                Next
            End If
        Next
        a = Application.Index(.items, 0, 0)
    End With
    With [d18:e18]
        .Resize(Rows.Count - .Row - 1).ClearContents
        .Resize(UBound(a, 1)).Value = a
    End With
    Application.EnableEvents = True
End Sub
 

Attachments

  • Test with code.xlsm
    24.2 KB · Views: 10
uploaded original file ...

Above code doesn't run original file

tab 2.planning fullname to be split first last name
 

Attachments

  • testfile.xlsm
    26.2 KB · Views: 8
@ Jindon...Your code works well but not on my worksheet , which had data validations..Kindly have a look at the latest attached file.
 
when copied to another spreadsheet ,Getting "Run time error Type-mismatch 13" and stops at highlighted RED

Any suggestion??

Private Sub Worksheet_Activate()
Dim a, i As Long, e
Application.EnableEvents = False
a = Sheets("2. Planning").Columns("c").SpecialCells(2).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
a(i, 1) = Application.Trim(a(i, 1))
If a(i, 1) <> "" Then
For Each e In Split(a(i, 1), ";")
.Item(Trim$(e)) = Split(Application.Trim(e))
Next
End If
Next
a = Application.Index(.items, 0, 0)
End With
With [d18:e18]
.Resize(Rows.Count - .Row - 1).ClearContents
.Resize(UBound(a, 1)).Value = a
End With
Application.EnableEvents = True
End Sub
 
Copy?
Change to this anyway
Code:
Private Sub Worksheet_Activate()
    Dim r As Range, a, i As Long, e
    Application.EnableEvents = False
    With Sheets("2. Planning")
        If .Range("c" & Rows.Count).End(xlUp).Row > 12 Then
            a = .Range("c12", .Range("c" & Rows.Count).End(xlUp)).Resize(, 2).Value
        End If
    End With
    If IsArray(a) Then
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                a(i, 1) = Application.Trim(a(i, 1))
                If a(i, 1) <> "" Then
                    For Each e In Split(a(i, 1), ";")
                        .Item(Trim$(e)) = Split(Application.Trim(e))
                    Next
                End If
            Next
            a = Application.Index(.items, 0, 0): i = .Count
        End With
    End If
    With [d18:e18]
        .Resize(Rows.Count - .Row - 1).ClearContents
        If IsArray(a) Then
            .Resize(i).Value = a
        End If
    End With
    Application.EnableEvents = True
End Sub
 
You already have a working solution. Test this on a backup. I have added my code to the code you've posted. Remove my code from the module. Replace the old code with this code.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
'\\ New Declarations start
Dim objDict As Object
Dim varData, rowData, varKey
Dim varOut()
Dim i As Long
'\\ New Declarations end

'\\ For any errors in existing code we'll jump straight to new code
If Target.Count > 1 Then GoTo ColumnCCode

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo ColumnCCode

If rngDV Is Nothing Then GoTo ColumnCCode

If Intersect(Target, rngDV) Is Nothing Then

Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If oldVal = "" Then
  Else
  If newVal = "" Then
  Else
  Target.Value = oldVal & "; " & newVal

  End If
  End If
End If

'\\New code start
ColumnCCode:
If Target.Column = 3 Then
    On Error GoTo exitHandler '// Just in case something fails
    Sheets("4. Mobile").Range("D18").CurrentRegion.ClearContents
    varData = Sheets("2. Planning").Range("C2:C" & Sheets("2. Planning").Range("C" & Rows.Count).End(xlUp).Row).Value
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.Comparemode = vbTextCompare
    For i = LBound(varData) To UBound(varData)
        rowData = Split(varData(i, 1), ";")
        For j = LBound(rowData) To UBound(rowData)
            If Not objDict.exists(Application.Trim(rowData(j))) Then
                objDict.Add Application.Trim(rowData(j)), Trim(rowData(j))
            End If
        Next j
    Next i
    ReDim varOut(objDict.Count - 1, 0 To 1)
    i = 0
    For Each varKey In objDict.keys
        varOut(i, 0) = Split(varKey, " ")(0)
        varOut(i, 1) = Split(varKey, " ")(1)
        i = i + 1
    Next
    Sheets("4. Mobile").Range("D18").Resize(UBound(varOut) + 1, 2).Value = varOut
End If
'\\ New code end

exitHandler:
Application.EnableEvents = True

End Sub
 
Works fine if full name is entered , Gives "run time error type mismatch 13" on highlighted in RED, when just firstname is entered.

If no spaces or just single(first\lastname) entered in Column "c" ,should copy to First name column D in Tab (4. Mobile)

Really Appreciate your work....

Private Sub Worksheet_Activate()
Dim r As Range, a, i As Long, e
Application.EnableEvents = False
With Sheets("2. Planning")
If .Range("c" & Rows.Count).End(xlUp).Row > 12 Then
a = .Range("c12", .Range("c" & Rows.Count).End(xlUp)).Resize(, 2).Value
End If
End With
If IsArray(a) Then
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
a(i, 1) = Application.Trim(a(i, 1))
If a(i, 1) <> "" Then
For Each e In Split(a(i, 1), ";")
.Item(Trim$(e)) = Split(Application.Trim(e))
Next
End If
Next
a = Application.Index(.items, 0, 0): i = .Count
End With
End If
With [d18:e18]
.Resize(Rows.Count - .Row - 1).ClearContents
If IsArray(a) Then
.Resize(i).Value = a
End If
End With
Application.EnableEvents = True
End Sub
 
That probably has to do with Single Name situation you have informed. Please test with below code.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
'\\ New Declarations start
Dim objDict As Object
Dim varData, rowData, varKey
Dim varOut()
Dim i As Long
'\\ New Declarations end

'\\ For any errors in existing code we'll jump straight to new code
If Target.Count > 1 Then GoTo ColumnCCode

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo ColumnCCode

If rngDV Is Nothing Then GoTo ColumnCCode

If Intersect(Target, rngDV) Is Nothing Then

Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If oldVal = "" Then
  Else
  If newVal = "" Then
  Else
  Target.Value = oldVal & "; " & newVal

  End If
  End If
End If

'\\New code start
ColumnCCode:
If Target.Column = 3 Then
    On Error GoTo exitHandler '// Just in case something fails
    Sheets("4. Mobile").Range("D18:E" & Sheets("4. Mobile").Range("D" & Rows.Count).End(xlUp).Row).ClearContents
    varData = Sheets("2. Planning").Range("C2:C" & Sheets("2. Planning").Range("C" & Rows.Count).End(xlUp).Row).Value
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.Comparemode = vbTextCompare
    For i = LBound(varData) To UBound(varData)
        rowData = Split(varData(i, 1), ";")
        For j = LBound(rowData) To UBound(rowData)
            If Not objDict.exists(Application.Trim(rowData(j))) Then
                objDict.Add Application.Trim(rowData(j)), Trim(rowData(j))
            End If
        Next j
    Next i
    ReDim varOut(objDict.Count - 1, 0 To 1)
    i = 0
    For Each varKey In objDict.keys
        varOut(i, 0) = Split(varKey & " ", " ")(0)
        varOut(i, 1) = Split(varKey & " ", " ")(1)
        i = i + 1
    Next
    Sheets("4. Mobile").Range("D18").Resize(UBound(varOut) + 1, 2).Value = varOut
End If
'\\ New code end

exitHandler:
Application.EnableEvents = True

End Sub
 
Code:
Private Sub Worksheet_Activate()
    Dim r As Range, a, i As Long, e, x
    Application.EnableEvents = False
    With Sheets("2. Planning")
        If .Range("c" & Rows.Count).End(xlUp).Row > 12 Then
            a = .Range("c12", .Range("c" & Rows.Count).End(xlUp)).Resize(, 2).Value
        End If
    End With
    If IsArray(a) Then
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                a(i, 1) = Application.Trim(a(i, 1))
                If a(i, 1) <> "" Then
                    For Each e In Split(a(i, 1), ";")
                        x = Split(Application.Trim(e))
                        ReDim Preserve x(1)
                        .Item(Trim$(e)) = x
                    Next
                End If
            Next
            a = Application.Index(.items, 0, 0): i = .Count
        End With
    End If
    With [d18:e18]
        .Resize(Rows.Count - .Row - 1).ClearContents
        If IsArray(a) Then
            .Resize(i).Value = a
        End If
    End With
    Application.EnableEvents = True
End Sub
 
Slight modification is reqd. on below code - Based on name in column D and F in "2. mobile" info is pulled from other sheet thru formulas/ vlookup and fillup data in row or info entered manually if missing against the name in the row.

Above Macro is entering name correctly, but deletes any data manually entered info in row "2. mobile" sheet and also if another name is entered only column D and F gets added up and info entered previously againist tht name gets mismatched.

ex : name entered Tom Kasik in column D and F in "2. mobile" pulls info from other sheet and fillup the row with phone number. If any data is entered manually ex :(number changed) in tht row and new name gets added /deleted..there's mismatch.


Code:
Private Sub Worksheet_Activate()
    Dim r As Range, a, i As Long, e, x
    Application.EnableEvents = False
    With Sheets("2. Planning")
        If .Range("c" & Rows.Count).End(xlUp).Row > 12 Then
            a = .Range("c12", .Range("c" & Rows.Count).End(xlUp)).Resize(, 2).Value
        End If
    End With
    If IsArray(a) Then
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                a(i, 1) = Application.Trim(a(i, 1))
                If a(i, 1) <> "" Then
                    For Each e In Split(a(i, 1), ";")
                        x = Split(Application.Trim(e))
                        ReDim Preserve x(1)
                        .Item(Trim$(e)) = x
                    Next
                End If
            Next
            a = Application.Index(.items, 0, 0): i = .Count
        End With
    End If
    With [d18:e18]
        .Resize(Rows.Count - .Row - 1).ClearContents
        If IsArray(a) Then
            .Resize(i).Value = a
        End If
    End With
    Application.EnableEvents = True
End Sub
 
Last edited by a moderator:
Back
Top