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

IKHAN · Apr 6, 2016

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?

shrivallabha · Apr 6, 2016

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

IKHAN · Apr 6, 2016

shrivallabha said:

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.

Chihiro · Apr 6, 2016

You'd need to combine 2 codes in same Worksheet_Change event.

As you can have only one Worksheet_Change event.

IKHAN · Apr 6, 2016

And please suggest how do i combine those 2 codes?

Chihiro · Apr 6, 2016

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.

jindon · Apr 6, 2016

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

IKHAN · Apr 7, 2016

uploaded original file ...

Above code doesn't run original file

tab 2.planning fullname to be split first last name

jindon · Apr 7, 2016

Did you understand what I posted?

IKHAN · Apr 7, 2016

@ Jindon...Your code works well but not on my worksheet , which had data validations..Kindly have a look at the latest attached file.

IKHAN · Apr 7, 2016

Thank you @jindon ...works well...

IKHAN · Apr 7, 2016

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

jindon · Apr 7, 2016

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

IKHAN · Apr 7, 2016

@jindon..Thank you much ...awesome..works like a charm.

shrivallabha · Apr 7, 2016

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

IKHAN · Apr 7, 2016

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

IKHAN · Apr 7, 2016

@shrivallabha ..Tried your code on back up , It wiped out my data in (4. mobile) above D18 and other columns in (4.mobile), didnt see names split.

shrivallabha · Apr 7, 2016

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

jindon · Apr 7, 2016

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

IKHAN · Apr 7, 2016

@ jindon ..Thanks so much..it works for just single name..

IKHAN · Apr 7, 2016

@shrivallabha ..Thank u for providing solutions.

You guys are the best.

IKHAN · Apr 15, 2016

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

IKHAN · Apr 15, 2016

It's D and E column not F

Deepak · Apr 16, 2016

IKHAN

Pls take liberty to use code tags.

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

Member

Attachments

Excel Ninja

Member

Excel Ninja

Member

Excel Ninja

Well-Known Member

Attachments

Member

Attachments

Well-Known Member

Attachments

Member

Member

Member

Well-Known Member

Member

Excel Ninja

Member

Member

Excel Ninja

Well-Known Member

Member

Member

Member

Member

Excel Ninja