Need a Macro for Compare and copy data from one sheet to another sheet in Excel.
Hi All,
I am new to Excel Macros and need experts Help, I was stuck up at Compare and copy data from one sheet to another sheet in Excel 2007.
I have a excel workbook which contains 3 sheets(sheet1 , sheet2 and sheet3). Sheet1 is master sheet of sheet2 and sheet3 means it will get data from these 2 sheets, so sheet1 columns are combination of sheet2 & sheet3 columns.
sheet2 & sheet3 are linked with different external sources and when ever changes will occur in external sources automatically these two sheets will get updated . so always these sheets are having latest data .
but sheet1 is getting data from sheet2 and sheet3, sheet1 is not updating every time when sheet3 got update ,since we are not automated the connection between sheet1 and sheet3.
our objective of this Macro is , it should compare the sheet1 and sheet3 based on Request Number(it is a unique and common column in both sheets) and needs to copy the whole row corresponding to the request number from sheet3 which does not exists in sheet1 and paste the data into corresponding columns in sheet1. we need to make sure that no duplicate values are occurred in Request Number in sheet1.( example sheet1 have 10 rows and sheet3 have 13 rows, in both sheets 10 rows are identical and remaining 3 rows added newly in sheet3. now we need to copy those 3 rows into sheet1 into corresponding coulmns)
here i have attached the macro code, it is working fine up to some content but not satisfying my requirement.
Sub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
End Sub
Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set rptWB = ActiveWorkbook
Application.DisplayAlerts = False
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 <> cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
rptWB.Saved = True
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub
Any help would be highly appreciated.
thanks in advance.
Regards,
Mallesham
|
