Sub ADDCLM()
'put all the variable definitions at top for easy reference
Dim Table1 As Range
Dim Table2 As Range
Dim lastRow As Long
Application.ScreenUpdating = False
Range("A1").EntireColumn.Insert
Range("U1").EntireColumn.Insert
Range("A1").Value = "UniqueID"
Range("U1").Value = Range("A1").Value
Range("A21").Value = Range("A1").Value
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
Range("A2:A" & lastRow).Formula = "=B2&""-""&N2"
Range("U2:U" & lastRow).Formula = "=A2"
Set Table1 = Sheet1.Range("A2:A292") ' Employee_ID Column from Employee table
Set Table2 = Sheet1.Range("U2:X374") ' Range of Employee Table 1
With Sheet1.Range("AA2").Resize(Table1.Rows.Count)
'Apply a worksheet formula to all cells in one shot
.Formula = "=VLOOKUP(A2," & Table2.Address & ",1,FALSE)"
.Copy
.PasteSpecial xlPasteValues
End With
With Sheet1.Range("AB2")
Range("AB2:AB" & lastRow).Formula = "=VLookup(A2, " & Table2.Address & ",2,FALSE)"
.Copy
.PasteSpecial xlPasteValues
End With
With Sheet1.Range("AC2")
Range("AC2:AC" & lastRow).Formula = "=VLookup(A2, " & Table2.Address & ",3,FALSE)"
.Copy
.PasteSpecial xlPasteValues
End With
With Sheet1.Range("AD2")
Range("AD2:AD" & lastRow).Formula = "=VLookup(A2, " & Table2.Address & ",4,FALSE)"
.Copy
.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
Dim ws As Worksheet, ws1 As Worksheet
Dim Rng As Range, cel As Range
Dim LR As Long, LR1 As Long
Dim Headers() As Variant
Set ws = Sheets("Sheet1")
Set ws1 = Sheets("Sheet2")
Application.ScreenUpdating = False
With ws
LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Headers = .Range("U1").Resize(1, 4).Value
With ws1
.Cells.Clear
.Range("A1").Resize(1, 4).Value = Headers
.Range("G1").Resize(1, 4).Value = Headers
End With
Set Rng = .Range(.Cells(2, "A"), .Cells(LR, "A"))
For Each cel In Rng
.Cells(cel.Row, "AF").Value = .Cells(cel.Row, "U") & Cells(cel.Row, "V") & Cells(cel.Row, "W") & Cells(cel.Row, "X")
.Cells(cel.Row, "AG").Value = .Cells(cel.Row, "AA") & Cells(cel.Row, "AB") & Cells(cel.Row, "AC") & Cells(cel.Row, "AD")
Next cel
Set Rng = .Range(.Cells(2, "AF"), .Cells(LR, "AF"))
For Each cel In Rng
If Not cel.Value = cel.Offset(0, 1).Value Then
With ws1
LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
.Range("A" & LR1).Resize(1, 4).Value = ws.Cells(cel.Row, "A").Resize(1, 4).Value
.Range("G" & LR1).Resize(1, 4).Value = ws.Cells(cel.Row, "G").Resize(1, 4).Value
End With
End If
Next cel
End With
With ws
.Columns("AF:AG").Delete
End With
Application.ScreenUpdating = True
Application.ScreenUpdating = True
MsgBox "Done"
End Sub