Moving Contact Database

Hi, I suck with this stuff, and have worked my way into a corner I'm afraid.

I am moving our old contact database to a new program. In the old database, the company ID that contacts reference to see what company they belong to are unique nvchar50 type characters that look like GKDF-22DK-....

For the new program, the company ID's are INT type, so when I exported everything from my old database into excel files, and tried to import that into the new database, the types are off, so it breaks.

I have 1 workbook, 2 excel sheets. The first excel sheet is the company export, listing their ID, address, etc. The second excel sheet is the contact export, listing the companyID it belongs to, the contacts name etc.

What I realize I need is some type of mass find and replace script, that will look at each company record in the company sheet, search matching company ID's on the contact sheet, and replace all those matching values with an integer type of 1. then on the next record, do the same thing, and increase the integer to 2, and so on for each record. So that all the contacts now refer to the same company, only with a different ID type, that I can then import to this new program.

Any help would be so awesome.

I've already tried doing the above on the SQL side, but that mucks everything up when exporting the data to excel, which I need to do for import.

Hi Michael

A sample of your data would be helpful. Include sheets 1 and 2 as you described and add a third sheet that demonstrates what you wish the results of your sample data to be. Perhaps one of us can help.

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.