Hi K,
There's more code than you might think.
Your problem was almost the same as a macro I had already written.
Good luck. It should run fine.
Sub MatchNamesAndWrite()
Dim INws As Worksheet 'file A and B raw name cells
Dim OUTws As Worksheet 'sheet where you want results written
Dim AyRowA As Long
Dim AyRowB As Long
Dim Col As Long
Dim CountA As Long 'how many A names
Dim CountB As Long 'how many B names
Dim FileAStartRow As Long 'where does file A start in INws
Dim FileAcol As Long 'column number of file A
Dim FileBStartRow As Long 'where does file B start in INws
Dim FileBcol As Long 'column number of file B
Dim Ix As Long
Dim Jx As Long
Dim MatchNum As Long
Dim Position As Long
Dim Row As Long
Dim Ubnd As Long
Dim FileAay As Variant 'array to hold A names, will be 2 dimensions
Dim KeyA As String
Dim FileBay As Variant 'array to hold B names, will be 2 dimensions
Dim KeyB As String
Dim SortAy As Variant
Dim SortHoldAy As Variant
Dim sHoldAy() As String 'work array to split name/file data
Dim sMisc As String 'work area variable
Dim FirstName As String
Dim LastName As String
Set INws = Sheets("Mar15") 'or ActiveSheet or ???
FileAStartRow = 1 ' change if value is different
FileAcol = 1 ' change column if different
FileBStartRow = 1 'change if value is different
FileBcol = 2 'change if column is different
With INws
' count the names in File A, null cell ends the count.
' 1000 for sure the end of A names row
For Row = FileAStartRow To 1000
If .Cells(Row, FileAcol).Value <> "" Then
CountA = CountA + 1
Else
Exit For 'end of A names
End If
Next Row
'do the same for file B
' 1000 for sure the end of B names row
For Row = FileBStartRow To 1000
If .Cells(Row, FileBcol).Value <> "" Then
CountB = CountB + 1
Else
Exit For 'end of B names
End If
Next Row
End With
ReDim SortHoldAy(1, 5) 'for sorting later
'there are 5 columns in each array row to hold data
'In this macro, only array columns 1 and 2 are used.
If CountA > 0 Then ReDim FileAay(1 To CountA, 5)
If CountB > 0 Then ReDim FileBay(1 To CountB, 5)
'Load File A with data, compose the sort key from
'the column A cell contents
With INws
AyRowA = 1 'first array row
For Row = FileAStartRow To FileAStartRow + CountA - 1
sMisc = .Cells(Row, FileAcol).Value 'cell as is into variable
sMisc = Trim(sMisc) 'remove any leading or trailing spaces
Do While InStr(sMisc, " ") > 0
sMisc = Replace(sMisc, " ", " ")
'make sure only 1 space between words
Loop
FileAay(AyRowA, 1) = sMisc 'adjusted cell value into array
'isolate the first name and last name
sHoldAy = Split(sMisc, " ")
'get items delimited by a space between them
Ubnd = UBound(sHoldAy) 'how many words, base 0 array
FirstName = sHoldAy(0)
If Ubnd < 1 Then
MsgBox Row & " row has no spaces, fix column A"
Exit Sub
End If
If InStr(sHoldAy(1), ".") > 0 Then
'last name has no space after it, but has a "."
'get name by using the position of the .
Position = InStr(sHoldAy(1), ".")
If Position < 1 Then
MsgBox "No space and no . after name in row " _
& Row & " , Fix column A"
Exit Sub
End If
LastName = Left(sHoldAy(1), Position - 1)
Else
LastName = sHoldAy(1)
End If
'make sort key of last,first and store in array column 2
sMisc = LastName & "," & FirstName
FileAay(AyRowA, 2) = sMisc
AyRowA = AyRowA + 1
Next Row
'Same thing , create file B
AyRowB = 1 'first array row
For Row = FileBStartRow To FileBStartRow + CountB - 1
sMisc = .Cells(Row, FileBcol).Value 'cell as is into variable
sMisc = Trim(sMisc) 'remove any leading or trailing spaces
Do While InStr(sMisc, " ") > 0
sMisc = Replace(sMisc, " ", " ")
'make sure only 1 space between words
Loop
FileBay(AyRowB, 1) = sMisc 'adjusted cell value into array
'isolate the first name and last name
sHoldAy = Split(sMisc, " ")
'get items delimited by a space between them
Ubnd = UBound(sHoldAy) 'how many words, base 0 array
FirstName = sHoldAy(0)
If Ubnd < 1 Then
MsgBox Row & " row has no spaces, fix column B"
Exit Sub
End If
If InStr(sHoldAy(1), ".") > 0 Then
'last name has no space after it, but has a "."
'get name by using the position of the .
Position = InStr(sHoldAy(1), ".")
If Position < 1 Then
MsgBox "No space and no . after name in row " _
& Row & " , Fix column B"
Exit Sub
End If
LastName = Left(sHoldAy(1), Position - 1)
Else
LastName = sHoldAy(1)
End If
'make sort key of last,first and store in array column 2
sMisc = LastName & "," & FirstName
FileBay(AyRowB, 2) = sMisc
AyRowB = AyRowB + 1
Next Row
End With 'InWs
If CountA > 1 Then 'sort only with 2 or more items
SortAy = FileAay
GoSub Sort
FileAay = SortAy
End If
If CountB > 1 Then
SortAy = FileBay
GoSub Sort
FileBay = SortAy
End If
Set OUTws = INws 'you can write to a different sheet, as desired.
FileAcol = 4 'column D change #'s for a different location
FileBcol = 6 'column F
With OUTws
'much quicker when writing to sheets
Application.ScreenUpdating = False
'sheet output start row, change #'s for a different location
Row = 1
If CountA > 0 And CountB > 0 Then
'Now, we can match the two sorted files that have a common
'key. Do not write over the input.
'This matching model assumes there may be more than one array
'row with the same key; LastName,FirstName. You did not say
'anything about that in your problem statement.
AyRowA = 1
KeyA = FileAay(AyRowA, 2) 'last,first
AyRowB = 1
KeyB = FileBay(AyRowB, 2) 'last,first
'end of file marker high values
Do While KeyA <> "zzzzzz" And KeyB <> "zzzzzz"
MatchNum = StrComp(KeyA, KeyB, vbTextCompare)
If MatchNum = 0 Then
'have a match, write both, add 1 to both array rows
.Cells(Row, FileAcol).Value = FileAay(AyRowA, 1) 'column A text
.Cells(Row, FileBcol).Value = FileBay(AyRowB, 1) 'column B text
AyRowA = AyRowA + 1 'new A file row
AyRowB = AyRowB + 1 'new B file row
ElseIf MatchNum = 1 Then 'file A higher
'write and read file B
.Cells(Row, FileBcol).Value = FileBay(AyRowB, 1)
AyRowB = AyRowB + 1
ElseIf MatchNum = -1 Then 'file A lower
'write and read file A
.Cells(Row, FileAcol).Value = FileAay(AyRowA, 1)
AyRowA = AyRowA + 1
End If
If AyRowA <= CountA Then
KeyA = FileAay(AyRowA, 2)
Else
KeyA = "zzzzzz"
End If
If AyRowB <= CountB Then
KeyB = FileBay(AyRowB, 2)
Else
KeyB = "zzzzzz"
End If
Row = Row + 1 'new sheet row
Loop
ElseIf CountA > 0 Then
'no file B names, write only file A
For AyRowA = 1 To CountA
.Cells(Row, FileAcol).Value = FileAay(AyRowA, 1)
Row = Row + 1 'worksheet row
Next AyRowA
Else
'no file A names, write only file B
For AyRowB = 1 To CountB
.Cells(Row, FileBcol).Value = FileBay(AyRowB, 1)
Row = Row + 1 'worksheet row
Next AyRowB
End If
End With
Application.ScreenUpdating = True
Exit Sub
Sort: 'Sort file, ascending, on the key in array column 2.
'This is a bubble sort, "in place".
'It will do about 500 array rows in 1 second.
For Ix = LBound(SortAy, 1) To (UBound(SortAy, 1) - 1)
For Jx = (Ix + 1) To UBound(SortAy, 1)
If StrComp(SortAy(Ix, 2), SortAy(Jx, 2), vbTextCompare) = 1 Then
'the lower file row has a greater value, so exchange the rows
For Col = LBound(SortAy, 2) To UBound(SortAy, 2)
SortHoldAy(1, Col) = SortAy(Ix, Col) 'store data this array row
SortAy(Ix, Col) = SortAy(Jx, Col) 'exchange
SortAy(Jx, Col) = SortHoldAy(1, Col) 'exchange
Next Col
End If
Next Jx
Next Ix
Return
End Sub
