Hi Trawets,
Find your workbook attached, it should do.
Please check the accuracy, since your data there are symbols and other
stuff in your data, it could match data that don't include dashes or
slashes... and the code below should be tweaked.
I think you can run it from the vba editor window or ask if it's new
to you. Hope it helps.
Option Explicit
Sub CompareCopyPasteByeBye()
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
Dim PartR() As String
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set wbk = ThisWorkbook
Set wksA = wbk.Worksheets(1)
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
lastr = wksA.Cells(Rows.Count, 2).End(xlUp).Row
lastc = wksA.Cells(1, Columns.Count).End(xlToLeft).Column
Set Romeo = wksA.Range(wksA.Cells(1, 1), wksA.Cells(lastr, lastc))
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
''''''''''''''''''''''''''''''
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
''''''''''''''''''''''''''''''
wksB.Rows(1).Copy wksC.Rows(1)
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
Romeo.Cells(j + 2, 2).Interior.ColorIndex = 3
End If
Next j
Next i
wksC.Columns(6).Interior.ColorIndex = xlNone
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
-o-
There should be (is) a better code than this, please let me know for
any optimization, 6000 rows, about 10 columns, for one array, half
less I think for another array, my 2 dynamic arrays hold key values
and the code takes 1 to 3 seconds to run single core pentium 4... I
would like to know if this can be done full speed using
scripting.dictionary or other methods (i'm not looking for an
algorithm killer here):)
Is anyone looking at this code able to assess my level of vba (it took
me 2 hours to produce this) since I don't how far i can use this skill
to apply for a job with vba skill require (i'm first an accountant and
for now i feel more comfortable with accounting but I do spend a lot
of time coding...i'm able to connect excel to database and words and
run queries or else however still with some time)?
Pascal Baro
--
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
