Moving Contact Database

Hi Michael
This code is in the attached. See if it does as you require. Run the code from the Button on Sheet "New_Company". Let me know of issues.

Option Explicit
Sub test()
    Dim LR1 As Long
    Dim LR2 As Long
    Dim rng1 As Range
    Dim rngAF As Range
    Dim cell1 As Range
    Dim r As Range
    Dim LResult As String
    Dim x As String
    Dim i As Long
    Application.ScreenUpdating = False
 
    Sheet3.Cells.ClearContents
    Sheet4.Cells.ClearContents
 
    Sheet1.Cells.Copy Destination:=Sheet3.Range("A1")
    Sheet2.Cells.Copy Destination:=Sheet4.Range("A1")
 
    With Sheet3
        .Activate
        LR1 = .Range("B" & .Rows.Count).End(xlUp).Row
        .Columns("B:B").Insert
        .Range("B1").Value = "COMPANYID"
        .Range("B2").Value = 1
        .Range("B3").Value = 2
        .Range("B2:B3").AutoFill Destination:=.Range("B2:B" & LR1), Type:=xlFillDefault
        Set rng1 = Sheet3.Range("C2:C" & LR1)
        Set r = Intersect(.Range("C1").EntireColumn, .UsedRange)
        r.Value = Evaluate("IF(ROW(" & r.Address & "),IF(" & r.Address & "<>"""",TRIM(" & r.Address & "),""""))")
    End With
    With Sheet4
        .Activate
        LR2 = .Range("C" & .Rows.Count).End(xlUp).Row
        .Columns("C:C").Insert
        .Range("C1").Value = "COMPANYID"
        Set r = Intersect(.Range("D1").EntireColumn, .UsedRange)
        r.Value = Evaluate("IF(ROW(" & r.Address & "),IF(" & r.Address & "<>"""",TRIM(" & r.Address & "),""""))")
    End With
    For Each cell1 In rng1
        x = Len(cell1.Value) - 2
        LResult = Left(cell1.Value, x)
        With Sheet4
            .Range("D1:D" & LR2).AutoFilter Field:=1, Criteria1:= _
                    "=*" & LResult & "*", Operator:=xlAnd
            Set rngAF = .AutoFilter.Range.Offset(1, 0).Resize _
                    (.AutoFilter.Range.Rows.Count).SpecialCells(xlCellTypeVisible)
            i = Application.WorksheetFunction.Subtotal(3, rngAF)
            If i >= 1 Then
                .Range("C2:C" & LR2).SpecialCells(xlCellTypeVisible).Value = cell1.Offset(0, -1).Value
            End If
            .AutoFilterMode = False
        End With
    Next cell1
    Sheet3.Columns("C").Delete
    Sheet4.Columns("D").Delete
    Application.ScreenUpdating = True
End Sub

Hi Michael

You're welcome...glad I could be of help.