Im having a collapsed data as shown below, where I have ID & its header below the header its value exists. Each ID has its own different no of headers & values.
I have to arrange them into a table where i have consolidated headers of all the IDs into one row and the IDs are in one column. Based one the ID i need to update the respective header's value below.
ID--+--H1--+--H2--+--H3--+--H4--+--H5--|
18219--V1--+--V3--+-- --+-- --+-- --|
18218--V2--+--V4--+-- --+-- --+-- --|
18217--V1--+--V2--+--V3--+--V4--+--V5--|
Can anyone help me out?
Try this code:
Option Explicit
Sub Consolidate()
Dim arrContent As Variant
Dim strSource As String
Dim strDest As String
Dim x As Long
Dim y As Long
Dim p As Long
Dim objHeader As Object
Dim objItem As Variant
Dim lngColsCount As Long
' set initial values
strSource = "source" ' source worksheet name
strDest = "destination" ' destination worksheet name
y = 1 ' source worksheet first ID cell's row number
x = 2 ' source worksheet first ID cell's column number
Set objHeader = CreateObject("Scripting.Dictionary")
' pack source data into array of dictionaries
objHeader.Add "ID", 0
arrContent = Array()
With Sheets(strSource)
Do While .Cells(y, x).Value <> "" And .Cells(y + 1, x).Value = ""
Set objItem = CreateObject("Scripting.Dictionary")
objItem.Add 0, .Cells(y, x).Value
p = x + 1
Do While .Cells(y, p).Value <> ""
If Not objHeader.Exists(.Cells(y, p).Value) Then objHeader.Add .Cells(y, p).Value, objHeader.Count
objItem(objHeader(.Cells(y, p).Value)) = .Cells(y + 1, p).Value
p = p + 1
Loop
ReDim Preserve arrContent(UBound(arrContent) + 1)
Set arrContent(UBound(arrContent)) = objItem
y = y + 2
Loop
End With
' output
With Sheets(strDest)
.Cells.Delete
lngColsCount = UBound(objHeader.keys)
.Range(.Cells(1, 1), .Cells(1, lngColsCount + 1)).Value = objHeader.keys
y = 2
For Each objItem In arrContent
For x = 1 To lngColsCount + 1
.Cells(y, x).Value = objItem(x - 1)
Next
y = y + 1
Next
End With
End Sub
For source table:
it generates output:
Related
I still consider myself a newbie with VBA, and would appreciate any help. There is one thing I am wondering how to do...
I have a worksheet like below, with data starting at row 16. I have a known number of rows (num_rows). I would like to loop through each row. Where Code = "s" I would like data exported to a s.txt, and where Code = "e" I would like data exported to e.txt. Other codes appear in the Code column which can be ignored. The outputted file would have each row on a new line, but also have sufficient spaces to align the data into their columns still in the text file. Any pointers?
Row#
Code
Title
Name
Country
16
s
Mr
James Smith
Australia
17
s
Mr
Karl Burns
USA
18
e
Mrs
Sara Sid
England
Scan the file to determine the maximum width of each column. Then scan again writing each line out with the columns padded to the required width with spaces. Copying the data to an array first will reduce the run time if you have a lot of data. See CreateTextFile and Space
Option Explicit
Sub Macro1()
Const HEADER_ROW = 15
Const COL_SPC = 2 ' column spacing
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Dim iRow As Long, iLastRow As Long, iLastCol As Integer
Dim r As Long, c As Integer, s As String, n As Integer
Dim arWidth() As Integer, arData, arHeader
' extent of data
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
iLastCol = ws.Cells(HEADER_ROW, Columns.Count).End(xlToLeft).Column
arData = ws.Range(ws.Cells(HEADER_ROW + 1, 1), ws.Cells(iLastRow, iLastCol))
' max width of each col
ReDim arWidth(iLastCol)
ReDim arHeader(iLastCol)
For c = 1 To UBound(arData, 2)
s = ws.Cells(HEADER_ROW, c)
arWidth(c) = Len(s) ' initalise with header width
For r = 1 To UBound(arData, 1)
If Len(arData(r, c)) > arWidth(c) Then
arWidth(c) = Len(arData(r, c))
End If
Next
' add spacing
arWidth(c) = arWidth(c) + COL_SPC
' space out header
arHeader(c) = s & Space(arWidth(c) - Len(s))
Next
'Export Data
Dim FSO As Object, ts(2), sFileName(2) As String
Dim sPath As String
Dim sColB, msg As String
Set FSO = CreateObject("Scripting.FileSystemObject")
sPath = wb.Path & "\"
' create 2 text streams
n = 1
For Each sColB In Array("e", "s")
sFileName(n) = sColB & ".txt"
Set ts(n) = FSO.CreateTextFile(sPath & sFileName(n), True, True) ' overwrite,unicode
' print header
ts(n).WriteLine Join(arHeader, "")
n = n + 1
Next
' export data
For r = 1 To UBound(arData, 1)
n = 0
' choose text stream
sColB = LCase(Trim(arData(r, 2)))
If sColB = "e" Then n = 1
If sColB = "s" Then n = 2
' write out 1 line of text
If n > 0 Then
s = ""
For c = 1 To UBound(arData, 2)
' space out columns
s = s & arData(r, c) & Space(arWidth(c) - Len(arData(r, c)))
Next
ts(n).WriteLine (s)
'Debug.Print s
End If
Next
' close text streams
For n = 1 To 2
msg = msg & vbCrLf & sFileName(n)
ts(n).Close
Next
' finish
MsgBox "2 Files created in " & sPath & msg
End Sub
I am trying to work out the looping on my script but have found it difficult to figure out. I am using this script to find matching data from different sources and reference them together. I would use the built-in functions in excel but it doesn't care about finding the same data more than once.
Read the titles of all the spreadsheets in the book. #Works
Make an array with those titles #Works
Filter out the "current" sheet #Works
Reference each cell in column A on "current" sheet against all the cells on all the pages in column H #Works
If it matches one, take the data from the page it was found on and the data in column G then set that as the value on "current" page in column E #Works
Make the next page in the main sheet array the "current" page and do it all over again #Doesn't Work
I didn't think this would be as complicated as it is, and maybe I'm not helping by not using functions. Got any idea on how to advance inspectSheet correctly?
Sub listsheets()
Dim ws As Worksheet
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim sheetArray() As Variant
x = 0
y = 0
i = 0
For Each ws In Worksheets
ReDim Preserve sheetArray(i)
sheetArray(i) = ws.Name
i = i + 1
Next ws
Do Until i = 1
i = i - 1
inspectSheet = sheetArray(x)
column = Sheets(inspectSheet).Cells(Rows.Count, "A").End(xlUp).Row
matchArray = Filter(sheetArray, inspectSheet, False, vbTextCompare)
HOLDER = Join(matchArray)
matchSheet = matchArray(y)
Do Until column = 1
currentCell = Sheets(inspectSheet).Cells(column, 1).Value
checkListLength = Sheets(matchSheet).Cells(Rows.Count, "H").End(xlUp).Row
Do Until checkListLength = 1
matchCell = Sheets(matchSheet).Cells(checkListLength, 8).Value
Debug.Print "Checking: " + currentCell + " on " + inspectSheet + " against " + matchCell + " from page " + matchSheet
If currentCell = matchCell Then
Sheets(inspectSheet).Cells(column, 5).Value = matchSheet + " on " + Sheets(matchSheet).Cells(checkListLength, 7).Value
End If
checkListLength = checkListLength - 1
Loop
column = column - 1
Loop
y = y + 1
Loop
x = x + 1
End Sub
I see you already answered your own question, but here's a slightly different approach with fewer counters to track:
Sub listsheets()
Dim wsMatch As Worksheet, wsInspect As Worksheet
Dim currVal
Dim cInspect As Range, cMatch As Range, rngMatch As Range, rngInspect As Range
For Each wsInspect In ThisWorkbook.Worksheets
Set rngInspect = wsInspect.Range("A1:A" & wsInspect.Cells(Rows.Count, "A").End(xlUp).Row)
For Each wsMatch In ThisWorkbook.Worksheets
If wsMatch.Name <> wsInspect.Name Then 'filter out same-name pairs...
Set rngMatch = wsMatch.Range("H1:H" & wsMatch.Cells(Rows.Count, "H").End(xlUp).Row)
For Each cInspect In rngInspect.Cells
currVal = cInspect.Value
For Each cMatch In rngMatch.Cells
If cMatch.Value = currVal Then
cInspect.EntireRow.Columns("E").Value = _
wsMatch.Name & " on " & cMatch.Offset(0, -1).Value
End If
Next cMatch
Next cInspect
End If 'checking these sheets
Next wsMatch
Next wsInspect
End Sub
I got it, I was not resetting my counter variables and needed one more external loop to advance. The finished code is:
Sub listsheets()
Dim ws As Worksheet
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim limit As Integer
Dim sheetArray() As Variant
x = 0
y = 0
i = 0
For Each ws In Worksheets
ReDim Preserve sheetArray(i)
sheetArray(i) = ws.Name
i = i + 1
Next ws
limit = UBound(sheetArray)
Do Until x = limit
Do Until i = 1
i = i - 1
inspectSheet = sheetArray(x)
Column = Sheets(inspectSheet).Cells(Rows.Count, "A").End(xlUp).Row
matchArray = Filter(sheetArray, inspectSheet, False, vbTextCompare)
HOLDER = Join(matchArray)
matchSheet = matchArray(y)
Do Until Column = 1
currentCell = Sheets(inspectSheet).Cells(Column, 1).Value
checkListLength = Sheets(matchSheet).Cells(Rows.Count, "H").End(xlUp).Row
Do Until checkListLength = 1
matchCell = Sheets(matchSheet).Cells(checkListLength, 8).Value
Debug.Print "Checking: " + currentCell + " on " + inspectSheet + " against " + matchCell + " from page " + matchSheet
If currentCell = matchCell Then
Sheets(inspectSheet).Cells(Column, 5).Value = matchSheet + " on " + Sheets(matchSheet).Cells(checkListLength, 7).Value
End If
checkListLength = checkListLength - 1
Loop
Column = Column - 1
Loop
y = y + 1
Loop
i = UBound(sheetArray)
y = 0
x = x + 1
Loop
End Sub
I have a Range ("A1:A"+finalRow), where finalRow is the last row at the "A" column and his value change randomly.
I need to extract each value from the range and assign each value to a different variable name, e.g. var1, var2, ..., var+finalRow.
In this case, I have 20 cells/values, part of my code as follows:
For y = 1 To finalRow
If finalRow = 20 Then
res1 = Range("A" + y).Value
pos1 = Range(1, y + 4).Address
res2 = Range("A" + y).Value
pos2 = Range(1, y + 4).Address
res3 = Range("A" + y).Value
pos3 = Range(1, y + 4).Address
'...
res20 = Range("A" + y).Value
pos20 = Range(1, y + 4).Address
ElseIf finalRow = 19 Then
res1 = Range("A" + y).Value
pos1 = Range(1, y + 4).Address
res2 = Range("A" + y).Value
pos2 = Range(1, y + 4).Address
res3 = Range("A" + y).Value
pos3 = Range(1, y + 4).Address
'...
res19 = Range("A" + y).Value
pos19 = Range(1, y + 4).Address
ElseIf finalRow = 18 Then
'...
ElseIf finalRow = 1 Then
res1 = Range("A" + y).Value
pos1 = Range(1, y + 4).Address
Next y
Is it possible to do the range tour without creating a lot of code?
A Mountain of Variables
The Code
Option Explicit
Sub AMoutainOfVariables()
Const FirstRow As Long = 1
Const ColumnString As String = "A"
Const ColumnOffset As Long = 4
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.ActiveSheet ' Better qualify with e.g. wb.worksheets("Sheet1").
Dim FinalRow As Long
FinalRow = 20
' Get values and cell addresses into an array.
Dim Data As Variant
Data = getColumnVnA(ws, ColumnString, FirstRow, FinalRow, , ColumnOffset)
' Now instead of
' res1, pos1, res2, pos2 ... you use:
' Data(1, 1), Data(1, 2), Data(2, 1), Data(2, 2) ...
' Now you can do something like the following.
' Write values and cell addresses to the Immediate window (CTRL+G).
Dim i As Long
For i = 1 To UBound(Data, 1)
Debug.Print Data(i, 1), Data(i, 2)
Next i
End Sub
' Writes the values and cell addresses of a one-column range, defined by its
' column string and first and last row numbers, to a 2D one-based two-column
' array.
Function getColumnVnA(Sheet As Worksheet, _
Optional ByVal ColumnString As String = "A", _
Optional ByVal FirstRowNumber As Long = 1, _
Optional ByVal LastRowNumber As Long = 1, _
Optional ByVal RowOffset As Long = 0, _
Optional ByVal ColumnOffset As Long = 0) _
As Variant
' Calculate Number of Rows ('NoR').
Dim NoR As Long
NoR = LastRowNumber - FirstRowNumber + 1
' Write values from One-Column Range to Data Array ('Data').
Dim Data As Variant
If NoR > 1 Then
' One-Column Range contains multiple cells.
Data = Sheet.Cells(FirstRowNumber, ColumnString).Resize(NoR).Value
Else
' One-Column Range contains one cell only.
ReDim Data(1 To 1, 1 To 1)
Data = Sheet.Cells(FirstRowNumber, ColumnString).Value
End If
' 'Add' a column to Data Array.
ReDim Preserve Data(1 To NoR, 1 To 2)
' Write cell addresses to 2nd column of Data Array.
Dim i As Long
For i = 1 To NoR
Data(i, 2) = Sheet.Range(ColumnString & CStr(i + FirstRowNumber - 1)) _
.Offset(RowOffset, ColumnOffset).Address(0, 0)
Next i
' Write result.
getColumnVnA = Data
End Function
Using arrays to simplify your code, you could do this (of course the explanatory comments can be omitted!!):
Dim Res(1 To 20) As Variant '-- Amended per VBasic2008's helpful suggestion
Dim Pos(1 To 20) As Variant
Dim y As Long
'-- NOTE: It's good practice to explicitly reference your workbook and worksheet.
'-- If you specify just "Range" without qualification, it will refer to whichever
'-- worksheet is active, and if you have more than one Excel workbook open,
'-- you could get unexpected results if you switch between workbooks.
'-- "ThisWorkbook" ensures you are referring to the workbook that's running this code.
'-- Sheets("Sheet1") ensures you are dealing with the named sheet only. Now ".Range"
'-- (don't omit the "."!!) can only refer to the cells in ThisWorkbook on Sheet1.
With ThisWorkbook.Sheets("Sheet1")
For y = 1 To finalRow
Res(y) = .Range("A" & y).Value
Pos(y) = .Cells(1, y + 4).Address
Next
End With
Now wherever you currently use Res1, Res2, etc. you would refer to Res(1), Res(2)... (i.e. the array element) instead.
Two further points:
You need to use "&" rather than "+" in your Range reference.
Your .Range(1, y + 4) won't work. Assuming you are trying to use a Row/Col combination here, it needs to be .Cells(1, y + 4).
I have a bubble sort that only works with the first element.
This is solved by reevaluating my array elements and placing them accordingly, which happens if I run the whole thing time and time again.
I'd like to add a recursive loop that's set to break when the sort is done.
I tried adding a function, but I'm not solid enough on my syntax to combine it with my sub. What is a basic recursion loop for this code? Function not expressly required, just something that will let me recall my sub.
Private Sub SortEverything_Click()
Dim everything() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
Dim everyrow As Long
Dim everycol As Long
Dim firstrow As Long
Dim firstcol As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "everything" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim everything(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set everything(y) = check
y = y + 1
check.Select
Next x
'This For has been commented out so that it doesn't run more than once
'For y = 0 To q - 1
'sorting allows us to copy/paste into a helper range line-by-line as the program loops
'firstman is the helper range. firstrow and firstcol return the dimensions of the everything(y) so that we can resize things
Set sorting = everything(0)
Set firstman = .Range("B20")
Set firstman = firstman.Resize(sorting.Rows.count, sorting.Columns.count)
firstman.Value = sorting.Value
firstrow = firstman.Rows.count
firstcol = firstman.Columns.count
'Returns the name of the RM listed to compare to the one below it
sorting.Offset(0, 1).Select
ActiveCell.Select
Temp1 = "" & ActiveCell.Value
For x = 1 To q - 1
'Checks whether a selected component has subcomponents and identifies its dimensions
sorting.Select
Set holder = everything(x)
holder.Offset(0, 1).Select
everyrow = Selection.Rows.count
everycol = Selection.Columns.count
'Returns the name of the material being compared to the referenced material in everything(y)
ActiveCell.Select
Temp2 = "" & ActiveCell.Value
If Temp2 > Temp1 Then 'If the RM we're on comes alphabetically after the name of the one we're checking against, then
If everyrow > 1 Then 'Handles if everything(x) has subcomponents
'Resize the other helper range to be the same as the range with subcomponents and paste the values into it
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(everyrow, everycol)
middleman.Select
middleman.Value = holder.Value
'Resize the range we're pasting into in the master table so it can take the new range, then paste
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
'Resize the holder column to the same size as everything(y).
'Then paste everything(y) into the space BELOW the one we've just shifted upwards
Set holder = holder.Resize(firstrow, firstcol)
Set holder = holder.Offset(everyrow - 1, 0)
holder.Select
holder.Value = firstman.Value
Set sorting = sorting.Offset(everyrow, 0)
Else
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(firstrow, firstcol)
middleman.Select
middleman.Value = holder.Value
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
Set holder = holder.Resize(firstrow, firstcol)
'Set firstman = firstman.Resize(everyrow, everycol)
holder.Select
holder = firstman.Value
Set sorting = sorting.Offset(1, 0)
End If
End If
Next x
'Next y
'This is where my inexperience shows. The recursion should go here, but I'm not sure how to do so.
'PopulateArray (everything)
End With
End Sub
Public Function PopulateArray(myArray()) As Variant
Dim myArray() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "myArray" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim myArray(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set myArray(y) = check
y = y + 1
check.Select
Next x
End With
End Function
Found out what I needed to do. Put the whole thing under a Do loop and then added the following lines to it:
'checking to see if array is completely alphabetized
For Each cell In .Range("B2:B" & lr)
'Returns first check value
If IsEmpty(cell) = False Then
cell.Select
check1 = "" & cell.Value
x = cell.Row
.Range("A14").Value = check1
'Returns next check value
For z = x + 1 To lr
Set checking = .Range("B" & z)
If IsEmpty(checking) = False Then
checking.Select
check2 = "" & .Range("B" & z).Value
.Range("A15").Value = check2
Exit For
End If
Next z
Else
End If
If check2 > check1 Then
Exit For
End If
Next cell
'If the last two values are sorted, then the whole thing is sorted and we can stop the recursion
If check2 < check1 Or check1 = check2 Then
Exit Do
End If
Dim rOriginal As Range 'row records in the lookup sheet (cList = Sheet2)
Dim rFind As Range 'row record in the target sheet (TotalList = Sheet1)
Dim rTableOriginal As Range 'row records in the lookup sheet (cList = Sheet2)
Dim rTableFind As Range 'row record in the target sheet (TotalList = Sheet1)
Dim shOriginal As Worksheet
Dim shFind As Worksheet
Dim booFound As Boolean
Dim shMix As Worksheet
'Initiate all used objects and variables
Set shOriginal = ThisWorkbook.Sheets("Male")
Set shFind = ThisWorkbook.Sheets("Female")
Set shMix = ThisWorkbook.Sheets("Mix")
Set rTableOriginal = shOriginal.Range(shOriginal.Rows(2), shOriginal.Rows(shOriginal.Rows.count).End(xlUp))
Set rTableFind = shFind.Range(shFind.Rows(2), shFind.Rows(shFind.Rows.count).End(xlUp))
booFound = False
For Each rOriginal In rTableOriginal.Rows
booFound = False
For Each rFind In rTableFind.Rows
'Check if the E and F column contain the same information
If rOriginal.Cells(1, 1) = rFind.Cells(1, 1) And rOriginal.Cells(1, 13) = rFind.Cells(1, 13) And rOriginal.Cells(1, 11) = rFind.Cells(1, 11) Then
'The record is found so we can search for the next one
booFound = True
GoTo FindNextOriginal 'Alternatively use Exit For
End If
Next rFind
'In case the code is extended I always use a boolean and an If statement to make sure we cannot
'by accident end up in this copy-paste-apply_yellow part!!
If booFound = True Then
'If not found then copy form the Original sheet ...
rOriginal.Copy
rFind.Copy
'... paste on the Find sheet and apply the Yellow interior color
With shMix.Rows(Mix.Rows.count + 1)
.PasteSpecial
End With
End If
FindNextOriginal:
Next rOriginal
So I have searched the site and came up with the codes above. But it still doesn't seem to work. My objective is to match 3 columns on sheet "Male" with another 3 columns on sheet "Female" if it matches, the code will then copy the row on both sheets and paste it on sheet "Mix". The columns I am trying to compare are columns A , K and M respectively.
Example:
Column A | Column K | Column M
1/1/2000 | 20 | 1
2/1/2000 | 21 | 4
3/1/2000 | 22 | 5
1/1/2000 | 20 | 1
4/1/2000 | 24 | 3
6/1/2000 | 25 | 6
Copy row 1 on both worksheet and paste it in sheet "Mix"
I've found that the most efficient method for something like a three column match is often a Scripting.Dictionary object that comes with its own unique reference key index. Temporary 'helper' columns that concatenate the three values for a single comparison are another option but 'in-memory' evaluation is usually the most efficient.
Sub three_col_match_and_copy()
Dim c As Long, v As Long, w As Long, vTMPs As Variant, itm As String, vVALs() As Variant, k As Variant
Dim dTMPs As Object '<~~ late binding use As New Scipting.Dictionary for early binding
Dim dMIXs As Object '<~~ late binding use As New Scipting.Dictionary for early binding
'late binding of the dictionary object
Set dTMPs = CreateObject("Scripting.Dictionary")
Set dMIXs = CreateObject("Scripting.Dictionary")
'grab all of Males into variant array
With Worksheets("male")
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
vTMPs = .Cells.Value2
End With
End With
End With
'build first dictionary
For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
If Not dTMPs.exists(Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203))) Then
itm = "gonna be discarded in any event"
dTMPs.Add Key:=Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203)), _
Item:=itm
End If
Next v
'grab all of Females into reused variant array
With Worksheets("female")
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
vTMPs = .Cells.Value2
End With
End With
End With
'save for later
c = UBound(vTMPs, 2)
'build second dictionary on matches
For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
If dTMPs.exists(Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203))) Then
itm = vTMPs(v, 1)
For w = LBound(vTMPs, 2) + 1 To UBound(vTMPs, 2)
itm = Join(Array(itm, vTMPs(v, w)), ChrW(8203))
Next w
dMIXs.Add Key:=Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203)), _
Item:=itm
End If
Next v
'continue if there is something to xfer
If CBool(dMIXs.Count) Then
'create variant array of the matches from the dictionary
v = 1
ReDim vVALs(1 To dMIXs.Count, 1 To UBound(vTMPs, 2))
Debug.Print LBound(vVALs, 1) & ":" & UBound(vVALs, 1)
Debug.Print LBound(vVALs, 2) & ":" & UBound(vVALs, 2)
For Each k In dMIXs
vTMPs = Split(dMIXs.Item(k), ChrW(8203))
For w = LBound(vTMPs) To UBound(vTMPs)
vVALs(v, w + 1) = vTMPs(w)
Next w
v = v + 1
Debug.Print dMIXs.Item(k)
Next k
'put the matched rows into the Mix worksheet
With Worksheets("mix")
With .Cells(1, 1).CurrentRegion
With .Resize(UBound(vVALs, 1), UBound(vVALs, 2)).Offset(1, 0)
.Cells = vVALs
End With
End With
End With
End If
dTMPs.RemoveAll: Set dTMPs = Nothing
dMIXs.RemoveAll: Set dMIXs = Nothing
End Sub
I have used raw values in the transfer. You will most likely have to correctly format things like date values in the Mix worksheet but that should not be a problem for a 'programming enthusiast'.
Kindly try the following code
Sub Test()
Dim lastr As Long
Dim lastrmale As Long
Dim lastrfemale As Long
Dim lastrmix As Long
Dim malesheet As Worksheet
Dim Femalesheet As Worksheet
Dim mixsheet As Worksheet
Dim i As Long
Set malesheet = Worksheets("Male")
Set Femalesheet = Worksheets("Female")
Set mixsheet = Worksheets("mix")
lastrmale = malesheet.Range("A" & malesheet.Range("A1").SpecialCells(xlLastCell).Row + 1).End(xlUp).Row
lastrfemale = Femalesheet.Range("A" & Femalesheet.Range("A1").SpecialCells(xlLastCell).Row + 1).End(xlUp).Row
lastr = WorksheetFunction.Min(lastrmale, lastrfemale)
lastrmix = 2
For i = 2 To lastr
If (malesheet.Range("A" & i).Value = Femalesheet.Range("A" & i).Value) And (malesheet.Range("K" & i).Value = Femalesheet.Range("K" & i).Value) And (malesheet.Range("M" & i).Value = Femalesheet.Range("M" & i).Value) Then
malesheet.Rows(i & ":" & i).Copy
mixsheet.Range("A" & lastrmix).PasteSpecial xlPasteAll
lastrmix = lastrmix + 1
Femalesheet.Rows(i & ":" & i).Copy
mixsheet.Range("A" & lastrmix).PasteSpecial xlPasteAll
lastrmix = lastrmix + 1
End If
Next
End Sub