Please find the code below with comment, although it is a little erratic...
It's really a basic pattern matching.
I assume G3198/3 is not the same as G31983 or 000G3198/3 or else...
Sub CompareCopyPasteByeBye()
'''DECLARE VARIABLES FOR OBJECTS AND ELSE
Dim wbk As Workbook
Dim wksA As Worksheet
Dim wksB As Worksheet
Dim wksC As Worksheet
Dim i As Long, j As Long, r As Long
Dim n As Long, m As Long
Dim lastr As Long, lastc As Long
Dim Romeo As Range, Sierra As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Comp() As String 'Dynamic array for components
Dim PartR() As String 'Dynamic array for PartR
With Application 'Disable temporarly some excel features for faster
processing
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set wbk = ThisWorkbook 'assign current workbook to make sure the code runs
on the right workbook
Set wksA = wbk.Worksheets(1) 'assign worksheet we're going to work with
Set wksB = wbk.Worksheets(2)
Set wksC = wbk.Worksheets(3)
''''''''''''''''''''''''''''''''''''''''''
'SHEET1 Components - Affectation to array
''''''''''''''''''''''''''''''''''''''''''
wksA.Range(wksA.Cells(1, 1), wksA.Cells(Rows.Count,
Columns.Count)).EntireRow.Hidden = False 'technical stuff to make sure the
code below find the end cells
wksA.Range(wksA.Cells(1, 1), wksA.Cells(Rows.Count,
Columns.Count)).EntireColumn.Hidden = False
lastr = wksA.Cells(Rows.Count, 2).End(xlUp).Row 'find the last row
lastc = wksA.Cells(1, Columns.Count).End(xlToLeft).Column 'find the last
column
Set Romeo = wksA.Range(wksA.Cells(1, 1), wksA.Cells(lastr, lastc)) 'assign
the range we need
'Assign values to array
ReDim Comp(lastr - 2)
For i = 2 To lastr
Comp(i - 2) = CStr(Romeo.Cells(i, 2))
Next i
''''''''''''''''''''''''''''''
'SHEET2 - Part Ref Affectation to array
''''''''''''''''''''''''''''''
'Same as with Sheet1
wksB.Range(wksB.Cells(1, 1), wksB.Cells(Rows.Count,
Columns.Count)).EntireRow.Hidden = False
lastr = wksB.Cells(Rows.Count, 6).End(xlUp).Row
lastc = wksB.Cells(1, Columns.Count).End(xlToLeft).Column
Set Sierra = wksB.Range(wksB.Cells(1, 1), wksB.Cells(lastr, lastc))
ReDim PartR(lastr - 2)
For i = 2 To lastr
PartR(i - 2) = CStr(Sierra.Cells(i, 6))
Next i
''''''''''''''''''''''''''''''
'EXPORTING Header
'STRING COMPARAISON
'Pasting Part ref values that match components
''''''''''''''''''''''''''''''
'Copy header row from Part Ref sheet to sheet3
wksB.Rows(1).Copy wksC.Rows(1)
'Check data that match and copy to sheet3
r = 2
For i = 0 To UBound(PartR)
For j = 0 To UBound(Comp)
If PartR(i) = Comp(j) Then
Sierra.Rows(i + 2).Copy wksC.Rows(r)
r = r + 1
Sierra.Cells(i + 2, 6).Interior.ColorIndex = 3 'highlight data
"pairs" on sheet1 and sheet2
Romeo.Cells(j + 2, 2).Interior.ColorIndex = 3
End If
Next j
Next i
'Remove cell highlights from sheet3
wksC.Columns(6).Interior.ColorIndex = xlNone
With Application 'return excel to its previous settings
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
On Sunday, March 4, 2012 2:47:20 PM UTC, trawets wrote:
> Thanks for the code and having tried this it works well, would it be
> possible to comment the code so I could follow it step by step and
> maybe try understand whats happens and when
>
>
--
FORUM RULES (986+ members already BANNED for violation)
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Cross-promotion of, or links to, forums competitive to this forum in
signatures are prohibited.
NOTE : Don't ever post personal or confidential data in a workbook. Forum
owners and members are not responsible for any loss.
------------------------------------------------------------------------------------------------------
To post to this group, send email to excel-macros@googlegroups.com
