Hi Trawets,
This code below should be more secured, reliable and faster for your 30,000
entries. You can double cross with the first code I sent and this code for
consistency, I find the same results with your first file but you should
try the code I'm sending you. It performs more consistent pattern matching.
Again feel free for real business challenges.
Sub CompareCopyPasteByeBye2()
Dim wbk As Workbook
Dim wksA As Worksheet
Dim wksB As Worksheet
Dim wksC As Worksheet
Dim Alpha As range, Bravo As range
Dim Romeo As range, Sierra As range
Dim Comp() As String, Part() As String
Dim CompBis() As String, PartBis() As String
Dim Uniques() As String
Const CCOL As Long = 2
Const PCOL As Long = 6
Dim i As Long
''
'''ASSIGN
''
Set wbk = ThisWorkbook
Set wksA = wbk.Worksheets(1)
Set wksB = wbk.Worksheets(2)
Set wksC = wbk.Worksheets(3)
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set Alpha = SetMyRange(wksA, CCOL)
Set Bravo = SetMyRange(wksB, PCOL)
Comp() = SetRangeWithRows(Alpha, CCOL)
Part() = SetRangeWithRows(Bravo, PCOL)
CompBis() = StripTease(Comp())
PartBis() = StripTease(Part())
Erase Comp
Erase Part
wksB.range("1:1").Copy
wksC.range("A1").PasteSpecial xlPasteValues
Set Sierra = BellyDance(CompBis(), PartBis(), wksA, wksB, wksC)
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With
'''UNASSIGN
Set Alpha = Nothing
Set Bravo = Nothing
Set Sierra = Nothing
Set wbk = Nothing
Set wksA = Nothing
Set wksB = Nothing
Set wksC = Nothing
End Sub
'How do I make a sub routing from below function???
Private Function BellyDance(ByRef ArrX() As String, ByRef ArrY() As String,
_
wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet)
Dim rg As range
Dim i As Long, j As Long
Dim r As Long
'rg.Value = "ok"
r = 2
For i = 0 To UBound(ArrX, 1)
For j = 0 To UBound(ArrY, 1)
If UCase(ArrY(j, 1)) = UCase(ArrX(i, 1)) Then
wks2.Rows(ArrY(j, 0)).Copy wks3.Rows(r)
r = r + 1
End If
Next j
Next i
Set rg = wks3.range("A1").CurrentRegion
Set BellyDance = rg
End Function
Private Function StripTease(ByRef tTab() As String) As Variant
Dim STab() As String
Const Abc As String =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
Dim tmpStore As String
Dim FLG As Boolean
Dim i As Long, j As Long
ReDim STab(UBound(tTab, 1), 1)
For i = 0 To UBound(tTab, 1)
tmpStore = ""
For j = 1 To Len(tTab(i, 1))
If InStr(j, Abc, Mid(tTab(i, 1), j, 1)) Then
FLG = True
tmpStore = tmpStore & Mid(tTab(i, 1), j, 1)
Else
FLG = False
End If
Next j
If FLG Then
STab(i, 0) = tTab(i, 0)
STab(i, 1) = tmpStore
End If
Next i
StripTease = STab()
End Function
Private Function SetRangeWithRows(ByRef r As range, ByRef nb As Long) As
Variant
Dim Arr() As String
Dim lastr As Long
Dim i As Long, j As Long
Dim cnt
lastr = r.Rows.Count
For i = 1 To lastr
If Len(r(i).Value) > 0 And CStr(r(i).Value) <> "N/A" Then
cnt = cnt + 1
End If
Next
cnt = cnt - 1: j = 0
ReDim Arr(cnt, 1)
For i = 1 To lastr
If Len(r(i).Value) > 0 And CStr(r(i).Value) <> "N/A" Then
Arr(j, 0) = CStr(i + 1)
Arr(j, 1) = CStr(r(i).Value)
j = j + 1
End If
Next i
SetRangeWithRows = Arr
End Function
Private Function SetMyRange(ByRef ws As Worksheet, ByRef ColNumb As Long)
As range
Dim rg As range
Dim lastr As Long
ws.range(ws.Cells(1, 1), ws.Cells(Rows.Count,
Columns.Count)).EntireRow.Hidden = False
ws.range(ws.Cells(1, 1), ws.Cells(Rows.Count,
Columns.Count)).EntireColumn.Hidden = False
lastr = ws.Cells(Rows.Count, ColNumb).End(xlUp).Row
Set rg = ws.range(ws.Cells(2, ColNumb), ws.Cells(lastr, ColNumb))
Set SetMyRange = rg
End Function
Again if someone can help me about vba optimization. I come from another
programming language background and it's really a challenge to deal with
objects...
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
