Pedro
asked on
combine code for Matching and Unmatched into one module
The idea is to create one module that holds/combines code for Matching and Unmatched into one module.
You will need to be much more specific. This is a comment rather than a question. Please provide details and/or specific examples in order for us to help you.
ASKER
Since the original code was written by Faustus, I believe he should first dibs on it, since he is also familiar with the code. Hopefully he posts by tomorrow so we don't keep others waiting too long.
Since the original code was written by Faustus, I believe he should first dibs on it, since he is also familiar with the code. Hopefully he posts by tomorrow so we don't keep others waiting too long.
Even though you have expressed your desire for a specific "Expert" to provide a solution in preference to anybody else, that should not deter other proposals being put forward & you assessing these on their own merits as they are presented to you.
An "Expert" engaged in a previous thread where the topic was the same, or was of a similar nature, may not contribute on a subsequent occasion, so you would be wise to not restrict the audience & alienate any other "Expert" from offering advice.
ASKER
I only did that because I was not to post too much code in posts and since this code exists I other threads it would take a lot of file. Nonetheless, I apologize and will post the necessary code tomorrow when I have access to the PC with the code.
I hate digging in other people's code for two reasons. For one, everybody has his own way of writing code for the very simple reason that everybody thinks that their particular way is the most efficient. If it weren't they would write the code differently.
For another, very often the code written at one time doesn't appear as efficient on second thought as it appeared at design time. Therefore there is a tendency to implement improvements, tempered only by the argument that something that isn't broken doesn't need fixing.
Digging in someone else's code brings out the worst in me on both counts, usually ending in my re-writing the code which is fair neither to the original author nor to myself, with the largely disinterested beneficiary exercising confounded tolerance.
Bottom line:- Please give extra credit to any one else taking on this ungrateful task. For me it's a lot easier, and I'll do it tomorrow.
For another, very often the code written at one time doesn't appear as efficient on second thought as it appeared at design time. Therefore there is a tendency to implement improvements, tempered only by the argument that something that isn't broken doesn't need fixing.
Digging in someone else's code brings out the worst in me on both counts, usually ending in my re-writing the code which is fair neither to the original author nor to myself, with the largely disinterested beneficiary exercising confounded tolerance.
Bottom line:- Please give extra credit to any one else taking on this ungrateful task. For me it's a lot easier, and I'll do it tomorrow.
ASKER
The code below finds umatched number sets in the attached file. The code in the file itself is the code to find matching sets. The idea is to combine both in the same file.
Thank you for your patience. This system gives me a problem every so often whenever i try to upload files.
Thank you for your patience. This system gives me a problem every so often whenever i try to upload files.
Option Explicit
Option Base 0
Const ResultSheetName As String = "Unmatched" ' modify as desired
Private Enum Npa ' Program parameters
NpaMaxPose = 65535 ' max rows that can be transposed
NpaMaxRows = 1048576 ' max rows per sheet
End Enum
Private Enum Nwm ' WsM: Worksheets navigation
NwmStart = 1 ' display start time
NwmEnd
NwmLapsed
NwmFirstDataRow
NwmTest = 1 ' Column A = 1
NwmFirstData ' = column next to NwmTest
End Enum
Private Enum Nws ' WsS: Worksheets navigation
NwsFirstData = 2 ' Column B = 2
NwsPreCount = 2 ' Number of data columns used for pre-sorting
NwsColCount = 5 ' Total number of data columns
End Enum
Sub ListUnmatched()
' modify as required:-
Const Numbers As String = "Numbers_"
Dim WsM As Worksheet ' Result sheet: Matching
Dim WsS As Worksheet ' Source sheets: Numbers_?
Dim Rslt()
Set WsM = GetSheet(ResultSheetName, True)
RecordTime WsM
SetApplication False
DeletePreviousResults ' all sheets with numbers as names
' or names commencing with "XX DEL"
For Each WsS In ThisWorkbook.Worksheets
' only tabs named with the variable 'Numbers' string
' followed by a number will be processed
If InStr(1, WsS.Name, Numbers, vbTextCompare) = 1 Then
If IsNumeric(Mid(WsS.Name, Len(Numbers) + 1)) Then
CreateTempList WsS
End If
End If
Next WsS
SortSheets
For Each WsS In ThisWorkbook.Worksheets
With WsS
If IsNumeric(WorksheetFunction.Substitute(.Name, " ", "")) Then
SortColumnA WsS
Rslt = GetResult(WsS)
If IsUsed(Rslt) Then ConvertAndWriteResult Rslt, WsM
End If
End With
Next WsS
If MsgBox("Do you wish to retain the pre-sorting result tabs?" & vbCr & _
"Press 'Yes' to prevent these tabs from being" & vbCr & _
"deleted at this time." & vbCr & vbCr & _
"You can run the procedure 'TestMan.CountResultRows'" & vbCr & _
"to analize the pre-sorting results." & vbCr & vbCr & _
"This program will delete all pre-sorting results," & vbCr & _
"as well as the tab '" & ResultSheetName & "' when you run" & vbCr & _
"the procedure 'ListMatching' again.", _
vbYesNo + vbDefaultButton2 + vbQuestion, _
"Final cleanup") <> vbYes Then DeletePreviousResults
WsM.Activate
RecordTime WsM, IsEnd:=True
SetApplication True
End Sub
Private Sub ConvertAndWriteResult(Arr() As Variant, _
WsM As Worksheet)
Dim PageArr()
Dim MatchArr() As String
Dim Dest As Range
Dim Rl As Long
Dim R As Long
Dim C As Long
Dim i As Long
For R = 1 To UBound(Arr)
If Len(Arr(R)) Then
i = i + 1
MatchArr = Split(Arr(R))
ReDim Preserve PageArr(1 To NwsColCount, 1 To i)
For C = 0 To UBound(MatchArr)
PageArr(C + 1, i) = MatchArr(C)
Next C
End If
If i = NpaMaxPose Or R = UBound(Arr) Then
Rl = LastRow(NwmFirstData, WsM) + 1
If Rl < NwmFirstDataRow Then Rl = NwmFirstDataRow
Set Dest = WsM.Cells(Rl, NwmFirstData)
Set Dest = Dest.Resize(UBound(PageArr, 2), UBound(PageArr))
Dest.Value = Application.Transpose(PageArr)
i = 0
Erase PageArr
End If
Next R
End Sub
Private Function GetResult(WsS As Worksheet) As Variant()
Dim PageArr()
Dim Rslt()
Dim IsDupl As Boolean
Dim R As Long
With WsS
R = LastRow(1, WsS)
If R Then
If R = 1 Then
ReDim PageArr(1 To 1, 1 To 1)
PageArr(1, 1) = .Cells(1, 1).Value
Else
PageArr = Range(.Cells(1, 1), .Cells(R, 1)).Value
End If
Else
Exit Function
End If
End With
For R = 1 To UBound(PageArr) - 1
If PageArr(R, 1) = PageArr(R + 1, 1) Then
IsDupl = True
Else
If IsDupl Then
IsDupl = False
Else
AddToResult R, WsS, PageArr, Rslt
End If
End If
Next R
If Not IsDupl Then
AddToResult R, WsS, PageArr, Rslt
End If
GetResult = Rslt
End Function
Private Sub AddToResult(ByVal R As Long, _
WsS As Worksheet, _
PageArr(), _
Rslt())
Dim i As Long
On Error Resume Next
i = UBound(Rslt)
i = i + 1
ReDim Preserve Rslt(1 To i)
Rslt(i) = WsS.Name & " " & PageArr(R, 1)
End Sub
Private Sub CreateTempList(WsS As Worksheet)
Dim WsT As Worksheet ' Temporary sheet
Dim PageArr()
Dim MatchArr()
Dim PreMatch As String
Dim PrevPre As String
Dim R As Long
Dim Rl As Long
Dim i As Long
Rl = LastRow(NwsFirstData, WsS)
R = FirstRow(NwsFirstData, Rl, WsS)
With WsS
If Rl = NwsFirstData Then
ReDim PageArr(1, 1)
PageArr(1, 1) = WsS.Cells(1, NwsFirstData).Value
Else
PageArr = Range(.Cells(R, NwsFirstData), _
.Cells(Rl, NwsFirstData + NwsColCount - 1)).Value
End If
End With
For R = 1 To UBound(PageArr)
PreMatch = TestString(R, NwsFirstData, _
NwsFirstData + NwsPreCount - 1, PageArr)
If PreMatch <> PrevPre Then
If IsUsed(MatchArr) Then
WriteArrayToColumn MatchArr, 1, WsT
i = 0
End If
Set WsT = GetSheet(PreMatch)
End If
i = i + 1
ReDim Preserve MatchArr(1 To i)
MatchArr(i) = TestString(R, NwsFirstData + NwsPreCount, _
UBound(PageArr, 2) + 1, PageArr)
PrevPre = PreMatch
Next R
WriteArrayToColumn MatchArr, 1, WsT
End Sub
Private Function TestString(ByVal R As Long, _
ByVal Cstart As Long, _
ByVal Cend As Long, _
PageArr()) As String
Dim TestArr() As String
Dim Ctop As Long
Dim i As Long
Ctop = Cend - Cstart
ReDim TestArr(Ctop)
For i = 0 To Ctop
TestArr(i) = Format(PageArr(R, Cstart + i - 1), "00")
Next i
TestString = Join(TestArr)
End Function
Private Sub WriteArrayToColumn(Arr() As Variant, _
ByVal Col As Long, _
Ws As Worksheet)
Dim Tmp() As Variant
Dim Dest As Range ' paste destination
Dim R As Long, C As Long
Dim i As Long, j As Long, k As Long
R = LastRow(Col, Ws)
i = R + UBound(Arr)
If i > NpaMaxRows Then
i = UBound(Arr)
ReDim Preserve Arr(NpaMaxRows - R)
MsgBox "Adding the array to the column would require" & vbCr & _
"more worksheet rows than Excel can handle." & vbCr & _
"The last " & i - UBound(Arr) & _
" array elements have been truncated."
End If
R = 1
C = -Int(UBound(Arr) / -NpaMaxPose)
For i = 1 To C
ReDim Tmp(1 To IIf(i = C, (UBound(Arr) Mod NpaMaxPose), NpaMaxPose))
For j = 1 To NpaMaxPose
k = R + j - 1
If k > UBound(Arr) Then Exit For
Tmp(j) = Arr(k)
Next j
Set Dest = Ws.Cells(LastRow(Col, Ws) + 1, Col)
Set Dest = Dest.Resize(UBound(Tmp), 1)
Dest.Value = Application.Transpose(Tmp)
R = i * NpaMaxPose + 1
Next i
Erase Arr
End Sub
Private Function GetSheet(ByVal Sn As String, _
Optional ByVal GetNew As Boolean) As Worksheet
Dim Idx As Long
If GetNew Then DelSheet Sn
With ThisWorkbook
On Error Resume Next
Set GetSheet = .Sheets(Sn)
If Err = 0 Then Exit Function
On Error GoTo 0
Set GetSheet = .Worksheets.Add(Before:=.Sheets(1))
ActiveSheet.Name = Sn
End With
End Function
Private Sub DeletePreviousResults()
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
If IsNumeric(WorksheetFunction.Substitute(Ws.Name, " ", "")) _
Or InStr(Ws.Name, "XX DEL") > 0 Then
DelSheet Ws.Name
End If
Next Ws
End Sub
Private Sub DelSheet(ByVal Sn As String)
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(Sn).Delete
Application.DisplayAlerts = True
End Sub
Private Function IsUsed(Arr()) As Boolean
Dim test As Long
On Error Resume Next
test = UBound(Arr)
IsUsed = Not CBool(Err)
End Function
Function FirstRow(ByVal Col As Long, _
ByVal Rl As Long, _
Ws As Worksheet) As Long
Dim R As Long
R = 1
Do While Len(Ws.Cells(R, Col).Value) = 0 _
And Rl > R
R = R + 1
Loop
FirstRow = R
End Function
Function LastRow(ByVal Col As Variant, _
Ws As Worksheet) As Long
' 0059 V 3.2x Sep 16, 2013
Dim R As Long
With Ws
R = .Cells(.Rows.Count, Col).End(xlUp).Row
With .Cells(R, Col)
If R = 1 And .Value = vbNullString Then R = 0
LastRow = R + .MergeArea.Rows.Count - 1
End With
End With
End Function
Private Sub SetApplication(ByVal Target As Boolean)
With Application
.ScreenUpdating = Target
.Cursor = IIf(Target, xlDefault, xlWait)
End With
End Sub
Private Sub RecordTime(WsM As Worksheet, _
Optional ByVal IsEnd As Boolean)
Const DateFormat As String = " d.m.yy h:mm:ss"
Dim Lapsed As Double
With WsM.Columns(1)
If IsEnd Then
.Cells(NwmEnd).Value = "Finished: " & Format(Now, DateFormat)
Lapsed = Now - .Cells(NwmStart).Value
With .Cells(NwmLapsed)
.NumberFormat = """Lapsed: ""[HH]:mm:ss"
.HorizontalAlignment = xlLeft
.Value = Lapsed
End With
Else
With .Cells(NwmStart)
.NumberFormat = """Started: """ & DateFormat
.HorizontalAlignment = xlLeft
.Value = Now
.Columns.AutoFit
End With
.Cells(NwmEnd).Value = "This may take some time. Please wait patiently :-)"
End If
End With
End Sub
Private Sub SortColumnA(Ws As Worksheet)
Dim Rng As Range
With Ws.Columns(1)
Set Rng = Range(.Cells(1), .Cells(LastRow(1, Ws)))
End With
With Ws.Sort
With .SortFields
.Clear
.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
End With
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Sub SortSheets()
Dim Done As Boolean
Dim LastToSort As Integer
Dim i As Integer
With ThisWorkbook.Worksheets
On Error Resume Next
LastToSort = .Item(ResultSheetName).Index
If LastToSort = 0 Then LastToSort = .Count
On Error GoTo 0
Do
Done = True
For i = 1 To LastToSort - 2
If StrComp(.Item(i + 1).Name, .Item(i).Name, _
vbTextCompare) = True Then
.Item(i + 1).Move Before:=.Item(i)
Done = False
End If
Next i
Loop Until Done
End With
End Sub
Copy-of-EXX-130918-Match-Combina.xlsb
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Excellent work, Thank you.