avatar
Untitled

Guest 72 29th Nov, 2019

MARKUP 1.11 KB
                                           
                         Option Explicit

Sub GetLastNames()

    Dim sCellValue As String
    
    Dim sCapitalWord As String
    Dim sSplitValue As Variant
    Dim i As Integer, j As Integer, iColumnWithNames As Integer, iLastNameColumn
    
    'ange kolumnnummer som innehåller fullständiga namnet
    iColumnWithNames = 1
    
    'Ange vilken kolumn resultat ska skrivas till.
    'OBS! Alla värden som finns i cellerna skrivs över!
    iLastNameColumn = 5
    
    
    For i = 1 To 10000
        sCellValue = Cells(i, iColumnWithNames).Value
        If sCellValue Like "" Then Exit Sub
        
        Dim sSplitValues As Variant

        sSplitValues = Split(sCellValue, " ")
        For j = LBound(sSplitValues) To UBound(sSplitValues)
            sSplitValue = sSplitValues(j)
            If sSplitValue Like UCase(sSplitValue) Then
                Cells(i, iLastNameColumn).Value = Right(sCellValue, Len(sCellValue) - InStr(sCellValue, sSplitValue) + 1)
                GoTo nexti
            End If
        Next j
nexti:
    Next i
    
End Sub
                      
                                       
To share this paste please copy this url and send to your friends
RAW Paste Data
Recent Pastes