Compare two columns and fill in a third column

Question

I want to find out the records with same group from Column AS in Column AT and add missing invoices in Column AU considering all the values from the group in Column as below table:

Jan|Feb|Mar|ColumnAS|ColumnAT|ColumnAU

30ドル|blank|blank|AAA|AAA|Feb

blank|blank|blank|AAA|blank|blank

blank|blank|35ドル|AAA|blank|blank

blank|blank|blank|AAB|AAB|Jan,Mar

blank|20ドル|blank|AAB|blank|blank

blank|blank|blank|AAB|blank|blank

I have created 2 loops one (j) which runs through all values from Column AS and other (k) through AT. Temp2 is used to add unique values to column AT after comparing values from temp1

Code:

Sub MissingMonth()
Dim wSheet As Worksheet
Dim LastRow As Long
Dim temp1 As String
Dim temp2 As String
Dim j As Long, k As Long
Set wSheet = ThisWorkbook.Sheets("Source Data")
 wSheet.Select
 LastRow = ThisWorkbook.Sheets("Source Data").Cells(Rows.Count, "A").End(xlUp).Row
 temp2 = vbNullString
 For j = 2 To LastRow
 If Not (wSheet.Range("AS" & j) = temp2) Or temp2 = vbNullString Then
 temp1 = wSheet.Range("AS" & j)
 wSheet.Range("AU" & j) = "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"
 For k = 2 To LastRow
 temp2 = temp1
 wSheet.Range("AT" & j) = temp2
 If wSheet.Range("AS" & k) = temp2 Then
 Call CheckMissingMonth(k, temp2, "I", j, "Jan ")
 Call CheckMissingMonth(k, temp2, "J", j, "Feb ")
 Call CheckMissingMonth(k, temp2, "K", j, "Mar ")
 Call CheckMissingMonth(k, temp2, "L", j, "Apr ")
 Call CheckMissingMonth(k, temp2, "M", j, "May ")
 Call CheckMissingMonth(k, temp2, "N", j, "Jun ")
 Call CheckMissingMonth(k, temp2, "O", j, "Jul ")
 Call CheckMissingMonth(k, temp2, "P", j, "Aug ")
 Call CheckMissingMonth(k, temp2, "Q", j, "Sep ")
 Call CheckMissingMonth(k, temp2, "R", j, "Oct ")
 Call CheckMissingMonth(k, temp2, "S", j, "Nov ")
 Call CheckMissingMonth(k, temp2, "T", j, "Dec")
 End If
 Next k
 End If
 Next j
 Set wSheet = Nothing
End Sub
 Sub CheckMissingMonth(k As Long, TempMonth As String, ColumnName As String, j As Long, Replacevalue As String)
 If Not IsEmpty(ThisWorkbook.Sheets("Source Data").Cells(k, ColumnName)) Then
 ThisWorkbook.Sheets("Source Data").Range("AU" & j).Replace What:=Replacevalue, Replacement:="", LookAt:=xlPart, MatchCase:=False
 End If
End Sub

Answer 1

This is how I understand the requirements

Before enter image description here

After enter image description here

• Column A is required (implied by how last row is determined)
• Light red = group 1 (AAA); dark red = missing months for group 1
• Light blue = group 2 (AAB); dark blue = missing months for group 2
• If current record is in the same as group as previous don't update columns AT and AU

---

About the posted code

I found the logic a bit convoluted and hard follow (or maintain)

• Indentation is inconsistent
• Naming convention doesn't provide many clues for intent, examples:
  • MissingMonth() should be FindMissingMonths() or ShowMissingMonth()
  • temp1 and temp2 don't imply anything helpful, yet temp2 is critical
  • Usual loop counters are i, j, k (nesting hierarchy) - probably i was used at some point, then removed
  • LastRow (local variable names) should start with a lower case letter
• temp1 is not needed

• wSheet is assigned but in the LastRow assignment wSheet is not used:

  LastRow = ThisWorkbook.Sheets("Source Data").Cells(Rows.Count, "A").End(xlUp).Row

  should be

  LastRow = wSheet.Cells(wSheet.Rows.Count, "A").End(xlUp).Row

• in sub CheckMissingMonth(), parameter TempMonth is not used

• there are too many interactions with the sheet, especially when calling CheckMissingMonth() and they cause slowness

---

This is how I would improve it for compactness and maintainability (削除) (and a bit for performance) (削除ここまで):

Version 1

Option Explicit
Public Sub findMissingMonths()
 Const JAN = 9 'start column
 Dim lastRow As Long, i As Long, j As Long, k As Long, miss As String, rng As Range
 Dim prevAS As String, mths As String, mthArr As Variant, lastMonth As Byte
 With ThisWorkbook.Sheets("Source Data")
 Set rng = .Range(.Cells(1, JAN), .Cells(1, JAN + 11)) 'get all months from headers
 mths = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(rng)))
 mthArr = Split(mths) '"Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"
 lastMonth = UBound(mthArr)
 lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
 For i = 2 To lastRow 'check colAS (continue only if new group)
 If .Range("AS" & i).Value2 <> prevAS Or Len(prevAS) = 0 Then
 miss = mths 'working string to remove the month from
 For j = 2 To lastRow 'check colAT
 prevAS = .Range("AS" & i).Value2 'remember previous val in colAS
 .Range("AT" & i).Value2 = prevAS
 For k = 0 To lastMonth 'del month from full str as needed
 If .Range("AS" & j).Value2 = prevAS Then
 If Len(.Cells(j, JAN + k).Value2) > 0 Then
 miss = Replace(Replace(miss, mthArr(k), ""), " ", " ")
 End If
 End If
 Next k
 Next j
 .Range("AU" & i).Value2 = Trim(miss) 'commit to cell
 End If
 Next i
 End With
End Sub

---

.

To optimize for performance I would eliminate all range interactions except for moving all data to memory and, at the end, placing it back on the sheet. This requires a bit more effort and code but the benefit is exponential

Here is another version optimized for speed, and this is the flow at high level:

• move all data to array (variant)

• create a nested dictionary that will keep track of each month value for each group:

• AAA

  • Jan = Present (boolean)
  • Feb = Missing
  • Mar = Present
  • ...

• AAB

  • Jan = Missing
  • Feb = Missing
  • Mar = Present
  • ...

• first loop:

  • read all groups from col AS (also in memory as a smaller variant array)
  • initialize all values to False
• second loop:
  • read all months' data and update all dictionary values to True as needed
  • update col AT and AU as needed (from dictionaries to array)
• write all array data back to the sheet

---

Example (including all helper functions in the same module):

Version 2

Option Explicit
Private Const MONTHS As String = "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"
Public Sub showMissingMonths() 'in VBE set reference to "Microsoft Scripting Runtime"
 Const COL_I As Long = 9 'Month columns I to T (9 to 20)
 Const COL_AS As Long = 45 'Work columns AS to AU (45 to 47)
 Dim ws As Worksheet, arr As Variant, missing As String
 Dim i As Long, j As Long, lastRow As Long, unique As Dictionary
 Set ws = ThisWorkbook.Sheets("Source Data")
 arr = ws.UsedRange 'copy the used range to array
 lastRow = UBound(arr) 'first dimmension of the 2D array
 Set unique = getUnique(ws.UsedRange.Columns(COL_AS).Offset(1).Resize(lastRow - 1))
 If unique.Count > 0 Then
 For i = 2 To lastRow 'by row, determine if each month contains a value
 For j = 0 To 11
 If Not unique(arr(i, COL_AS))(arr(1, COL_I + j)) Then
 unique(arr(i, COL_AS))(arr(1, COL_I + j)) = Len(arr(i, COL_I + j)) > 0
 End If
 Next
 Next
 For i = 2 To lastRow 'update colAU with missing month, only if new group
 If i = 2 Or arr(i - 1, COL_AS) <> arr(i, COL_AS) Then
 missing = vbNullString
 For j = 0 To 11
 If Not unique(arr(i, COL_AS))(arr(1, COL_I + j)) Then
 missing = missing & arr(1, COL_I + j) & ", "
 End If
 Next
 arr(i, COL_AS + 1) = arr(i, COL_AS)
 If Len(missing) > 0 Then arr(i, COL_AS + 2) = Left(missing, Len(missing) - 2)
 End If
 Next
 End If
 ws.UsedRange = arr 'commit back to range
End Sub

---

Private Function getUnique(ByRef rng As Range) As Dictionary
 Dim arr As Variant, i As Long, ub As Long, d As Dictionary, val As String
 arr = rng
 ub = UBound(arr)
 getNewDict d 'each group value contains a dictionary with all months
 If ub > 0 Then
 For i = 1 To ub
 val = arr(i, 1)
 If Len(val) > 0 Then If Not d.Exists(val) Then Set d(val) = getMonthDict
 Next
 End If
 Set getUnique = d 'returned dictionary can be empty
End Function

---

Private Sub getNewDict(ByRef d As Dictionary, Optional ByVal ignoreCase As Boolean = False)
 If Not d Is Nothing Then Set d = Nothing
 Set d = New Dictionary
 d.CompareMode = IIf(ignoreCase, vbTextCompare, vbBinaryCompare)
End Sub

---

Private Function getMonthDict(Optional ByVal ignoreCase As Boolean = False) As Dictionary
 Dim arr() As String, m As Variant, d As Dictionary
 getNewDict d
 arr = Split(MONTHS)
 For Each m In arr
 d(m) = False
 Next
 Set getMonthDict = d
End Function

---

PS. In a working module I'd declare all variables on separate lines, use longer and more meaningful names, and add more vertical white-spaces

PS1. Performance measurements:

Tests duration

• 1,000 records

  • As posted:29.672 sec
  • Version 1:53.320 sec
  • Version 2:0.047 sec

• 10.000 records

  • As posted:60.45 min (3,627.328 sec)
  • Version 1:109.30 min (6,558.547 sec)
  • Version 2:0.297 sec

• 100.000 records

  • Version 2:3.094 sec
  • Version 2:3.242 sec
  • Version 2:3.234 sec

• 1 Million records

  • Version 2:32.234 sec
  • Version 2:32.164 sec
  • Version 2:32.336 sec