Option Explicit
Option Base 1
Sub CombineTwo()
' hiker95, 06/28/2011
' http://www.mrexcel.com/forum/showthread.php?t=559828
Dim wB As Worksheet, wI As Worksheet, wC As Worksheet
Dim B() As Variant, I() As Variant, C() As Variant, BB() As Variant, II() As Variant
Dim LR As Long, a As Long, aa As Long, NR As Long, r As Long
Application.ScreenUpdating = False
Set wB = Worksheets("Incl Bus. Type")
Set wI = Worksheets("Incl ID")
If Not Evaluate("ISREF(Complete!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Complete"
Set wC = Worksheets("Complete")
wC.UsedRange.Clear
wC.Range("A1:B1") = [{"First Name","Last Name"}]
LR = wB.Cells(Rows.Count, 1).End(xlUp).Row
With wB.Range("F2:F" & LR)
.FormulaR1C1 = "=RC[-5]&RC[-4]"
.Value = .Value
End With
NR = wC.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wB.Range("A2:B" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wC.Range("A" & NR), Unique:=True
LR = wI.Cells(Rows.Count, 1).End(xlUp).Row
With wI.Range("F2:F" & LR)
.FormulaR1C1 = "=RC[-5]&RC[-4]"
.Value = .Value
End With
NR = wC.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wI.Range("A2:B" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wC.Range("A" & NR), Unique:=True
LR = wC.Cells(Rows.Count, 1).End(xlUp).Row
wC.Range("A2:B" & LR).Sort Key1:=wC.Range("B2"), Order1:=xlAscending, Key2:=wC.Range("A2") _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
wC.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wC.Range("C1"), Unique:=True
wC.Columns("A:B").Delete
With wC.Range("A1:F1")
.Value = [{"First Name","Last Name","Title","Account Name","Business Type","Contact ID"}]
.HorizontalAlignment = xlCenter
.Font.FontStyle = "Bold"
End With
LR = wC.Cells(Rows.Count, 1).End(xlUp).Row
With wC.Range("G2:G" & LR)
.FormulaR1C1 = "=RC[-6]&RC[-5]"
.Value = .Value
End With
LR = wB.Cells(Rows.Count, 1).End(xlUp).Row
B = wB.Range("A1:F" & LR).Value
BB = wB.Range("F1:F" & LR).Value
wB.Columns(6).Clear
LR = wI.Cells(Rows.Count, 1).End(xlUp).Row
I = wI.Range("A1:F" & LR).Value
II = wI.Range("F1:F" & LR).Value
wI.Columns(6).Clear
LR = wC.Cells(Rows.Count, 1).End(xlUp).Row
C = wC.Range("A1:G" & LR).Value
For a = LBound(C) + 1 To UBound(C)
r = 0
On Error Resume Next
r = Application.Match(C(a, 7), BB, 0)
On Error GoTo 0
If r > 0 Then
For aa = 3 To 5
If B(r, aa) <> "" Then C(a, aa) = B(r, aa)
Next aa
End If
r = 0
On Error Resume Next
r = Application.Match(C(a, 7), II, 0)
On Error GoTo 0
If r > 0 Then
For aa = 3 To 4
If I(r, aa) <> "" Then C(a, aa) = I(r, aa)
Next aa
If I(r, 5) <> "" Then C(a, 6) = I(r, 5)
End If
Next a
wC.Range("A1:G" & LR).Value = C
wC.Columns(7).Clear
wC.UsedRange.Columns.AutoFit
Erase B: Erase I: Erase C: Erase BB: Erase II
wC.Activate
Application.ScreenUpdating = True
End Sub
