Untruncate

Hank2

New Member
Joined
Aug 9, 2006
Messages
22
Need macro, not formula. Workbook A. Sheet 1 Column B starting in Row 7 has a variable number of names with spaces between the rows of names. Each name in the cells has been truncated to 11 spaces by a DB3 program.

Workbook B Sheet 4 has those same names in Column A sheet 4 starting in Row 4 that are not truncated.

I need a macro that will make Wkbk A search in Wkbk B for its similar name by matching the first 11 letters of text (including spacing). When it finds a match I want it to copy that from Wkbk B column A (which is the untruncated name) and the offset column by 1 (column B same row). Then I want it to paste it into Wkbk A Column N & O starting in Row 7. This will line up the truncated and untracated names in the same row.

Example:

Wkbk A Name (B7) Wkbk B Name (A4) Output Wkbk A (N7) (O7)

CAPTAIN VON CAPTAIN VON TRAPP CAPTAIN VON TRAPP 2


The names in the two lists don't necessarily coincide chronologically like this example. Must use match.
 
Last edited:

Some videos you may like

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Try this

Change data in red by your information.

Code:
Sub untruncate()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim cell1 As Range, b As Range, r As Range, largo As Long, celda As String
    
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
    
    Set wb2 = Workbooks("Wkbk B.xlsx")
    Set ws2 = wb2.Sheets("[COLOR=#ff0000]Sheet4[/COLOR]")
    Set r = ws2.Columns("A")
    
    For Each cell1 In ws1.Range("B7", ws1.Range("B" & Rows.Count).End(xlUp))
        largo = Len(cell1.Value)
        Set b = r.Find(cell1.Value, LookAt:=xlPart, LookIn:=xlValues)
        If Not b Is Nothing Then
            celda = b.Address
            Do
                If LCase(cell1.Value) = LCase(Left(b.Value, largo)) Then
                    ws1.Cells(cell1.Row, "N").Value = b.Value
                    ws1.Cells(cell1.Row, "O").Value = b.Offset(0, 1).Value
                    Exit Do
                End If
                Set b = r.FindNext(b)
            Loop While Not b Is Nothing And b.Address <> celda
        End If
    Next
    MsgBox "End"
End Sub
 

Hank2

New Member
Joined
Aug 9, 2006
Messages
22
At first I didn't think the code was copying the untracated names, but re copying the truncated names,until I looked closer. Guess I couldn't believe it. Like magic!. Thanks Dante. Good name.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Im glad to help you. I appreciate your kind comments.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,201
Messages
5,527,383
Members
409,759
Latest member
KCH

This Week's Hot Topics

Top