Identify matches between sheet columns

batman1 · #1 01-30-2025, 11:18 AM

Quote:

Originally Posted by gmaxey

Batman,

So, Solved already? Good luck

gmaxey · #2 01-30-2025, 05:53 PM

Quote:

Originally Posted by batman1

So, Solved already? Good luck

Batman,

After working with this code a bit more, I am going to mark this thread solved. I found that I didn't really need to use a dictionary at all and I believe the real efficiency gain was writing data to the arrays vice directly in the worksheet. The following code does 95% on what I need and with a 440,000 row REF sheet, it does it in under 9 seconds. That is a big improvement and I think with a little more work I can call the cannon ball fully polished. If someone comes along in this tread or the crosspost with a PowerQuery solution, I'll be eager to look at it but you have been a tremendous help. Thank you again!!

Code:

Option Explicit
Sub MyModified()
Dim oOS As Worksheet
Dim strColHeadings As String
Dim varNDS_Data(), varREF_Data(), varOverlay_Data()
Dim lngST As Long, lngIndex As Long, lngFldIndex As Long, lngItemIndex As Long, lngRecordIndex As Long, lngNDSRowIndex As Long
Dim lngOSRow As Long, lngOSCol As Long
Dim strFileName As String
Dim bMatched As Boolean, bNoMatch As Boolean, bNoREFMatchCanx As Boolean, bNoREFMatchCopyID As Boolean, bFirstMatch As Boolean
Dim bDupRow As Boolean, bConcatenateDupSC As Boolean, bConcatenateDupLF As Boolean, bNoMultiMatches As Boolean
Dim bDelim As Boolean, strDelimiter As String
  lngST = Timer
  strColHeadings = "REF/Contol#|Ser. Nb|Document Type|Document Date|Classification|Title|Description|Has Attachments|File Name"
  bMatched = False
  'NDS_Options Note: Only one on the next line shoul be true
  bFirstMatch = True: bDupRow = False: bConcatenateDupSC = False: bConcatenateDupLF = False: bNoMultiMatches = False
  'REF_Options Note: Normally both on next line are Fallse.  Only one on the next line can be true
  bNoREFMatchCopyID = False: bNoREFMatchCanx = False
  strDelimiter = ";": If bConcatenateDupLF = True Then strDelimiter = vbCrLf
  On Error Resume Next
  Set oOS = Worksheets("OVERLAY")
  If Err.Number = 0 Then
    Application.DisplayAlerts = False
    oOS.Delete
    Application.DisplayAlerts = True
  End If
  On Error GoTo 0
  Set oOS = Worksheets.Add
  oOS.Name = "OVERLAY"
  DoEvents
  With Worksheets("NDS_SHEET")
    lngIndex = .Cells(Rows.count, "A").End(xlUp).Row
    If lngIndex = 4 Then Exit Sub 'There is no data in NDS_SHEET
    varNDS_Data = .Range("A5").Resize(lngIndex - 4, 8).Value
  End With
  With Worksheets("REF_SHEET")
    lngIndex = .Cells(Rows.count, "A").End(xlUp).Row
    If lngIndex = 1 Then Exit Sub 'There is no data in REF_SHEET
    varREF_Data = .Range("A2").Resize(lngIndex - 1, 2).Value
  End With
  ReDim varOverlay_Data(1 To UBound(varREF_Data, 1), 1 To 9)
  For lngIndex = 1 To UBound(varREF_Data, 1)
    bNoMatch = True
    bMatched = False
    For lngItemIndex = 1 To UBound(varNDS_Data, 1)
      If InStr(1, varREF_Data(lngIndex, 2), varNDS_Data(lngItemIndex, 8), vbTextCompare) > 0 Then
        bNoMatch = False
        If Not bMatched Then
          lngRecordIndex = lngRecordIndex + 1
          varOverlay_Data(lngRecordIndex, 1) = varREF_Data(lngIndex, 1)
          lngNDSRowIndex = lngItemIndex + 1
          For lngFldIndex = 1 To 8
            varOverlay_Data(lngRecordIndex, lngFldIndex + 1) = varNDS_Data(lngNDSRowIndex, lngFldIndex)
          Next lngFldIndex
          If bFirstMatch Then Exit For
          bMatched = True
        Else
          If Not bNoMultiMatches Then
            If bDupRow Then
              lngRecordIndex = lngRecordIndex + 1
              varOverlay_Data(lngRecordIndex, 1) = varREF_Data(lngIndex, 1)
              lngNDSRowIndex = lngItemIndex + 1
              For lngFldIndex = 1 To 8
                varOverlay_Data(lngRecordIndex, lngFldIndex + 1) = varNDS_Data(lngNDSRowIndex, lngFldIndex)
              Next lngFldIndex
            Else
              For lngFldIndex = 1 To 8
                varOverlay_Data(lngRecordIndex, lngFldIndex + 1) = varOverlay_Data(lngRecordIndex, lngFldIndex + 1) & strDelimiter & varNDS_Data(lngNDSRowIndex, lngFldIndex)
              Next lngFldIndex
            End If
          Else
            MsgBox "Overlay function canceled due to multiple match on REF_SHEET row: " & lngIndex + 1
            GoTo lbl_Exit
          End If
        End If
      End If
   Next lngItemIndex
   Select Case True
     Case bNoREFMatchCopyID And bNoMatch
       lngRecordIndex = lngRecordIndex + 1
       'varOverlay_Data(lngRecordIndex, 1) = varREF_Data(lngIndex, 1)
     Case bNoREFMatchCanx And bNoMatch
       MsgBox "Overlay function canceled due to no NDS match for REF_SHEET row: " & lngIndex
       Exit For
   End Select
  Next lngIndex
  If lngRecordIndex Then oOS.Range("A2").Resize(lngRecordIndex, 9).Value = varOverlay_Data
  With oOS
     .Range("A1").Resize(1, 9).Value = Split(strColHeadings, "|")
    DoEvents
    .Rows(1).Font.Bold = True
    .Rows(1).AutoFilter
    .Rows(1).Select
    .Application.ActiveWindow.SplitColumn = 1
    .Application.ActiveWindow.SplitRow = 1
    .Application.ActiveWindow.FreezePanes = True
    DoEvents
    With .UsedRange
      .WrapText = False
      .EntireColumn.AutoFit
      If .ColumnWidth > 60 Then .ColumnWidth = 60
    End With
    DoEvents
    lngOSRow = 2
    Do While Len(.Cells(lngOSRow, 2).Value) > 0
      lngOSCol = 2
      Do While Len(.Cells(1, lngOSCol).Value) > 0
        .Cells(lngOSRow, lngOSCol).FormulaR1C1 = .Cells(lngOSRow, lngOSCol).Value
        lngOSCol = lngOSCol + 1
      Loop
      lngOSRow = lngOSRow + 1
    Loop
    .UsedRange.Columns.AutoFit
    .UsedRange.Rows.AutoFit
    DoEvents
    If bDupRow Then
      With .Columns(1)
        .FormatConditions.AddUniqueValues
        .FormatConditions(.FormatConditions.count).SetFirstPriority
        With .FormatConditions(1)
          .DupeUnique = xlDuplicate
          .Font.Color = -16383844
          .Font.TintAndShade = 0
          .Interior.PatternColorIndex = xlAutomatic
          .Interior.Color = 13551615
          .Interior.TintAndShade = 0
          .StopIfTrue = False
        End With
      End With
    End If
  End With
  MsgBox Timer - lngST
lbl_Exit:
  Set oOS = Nothing
  Exit Sub
lbl_Canx:
  Application.DisplayAlerts = False
  oOS.Delete
  Application.DisplayAlerts = True
  GoTo lbl_Exit
End Sub

batman1 · #3 01-31-2025, 04:53 AM

Quote:

Originally Posted by gmaxey

Batman,

After working with this code a bit more, I am going to mark this thread solved. I found that I didn't really need to use a dictionary at all and I believe the real efficiency gain was writing data to the arrays vice directly in the worksheet. The following code does 95% on what I need and with a 440,000 row REF sheet, it does it in under 9 seconds. That is a big improvement and I think with a little more work I can call the cannon ball fully polished. If someone comes along in this tread or the crosspost with a PowerQuery solution, I'll be eager to look at it but you have been a tremendous help. Thank you again!!

1. Yes, when there is a lot of data, reading/writing to the sheet should not be done cell by cell. Data should be read once into tables, something should be done on this data and once put into the sheet. And a dictionary can be useful. Note that at the beginning I did not know much about what you intended to do, you did not say anything about the data. At the beginning I did not know whether you were taking duplicates in H in the NDS_SHEET sheet but I assumed that I was not taking duplicates. So I am taking only the first one and will not check the next ones. I did not know anything about the data but it is possible that there are e.g. 10 duplicates of "DemoData_0000015_Import.zip". Of course, you can not use the dictionary, but each time you have to assess whether it is better to use the dictionary or not. Let's assume that there are 10 rows in NDS_SHEET and each one contains "DemoData_0000015_Import.zip" and in REF_SHEET 1000 rows and only 1 row contains "DemoData_0000015_Import.zip". There is only 1 result. DIC contains only 1 key and in the worst case, when "DemoData_0000015_Import.zip" is in the last row of REF_SHEET, the code executes 1000 FOR loops (1000 INSTR). If the dictionary is not used, then in the worst case after executing 999*10 = 9990 FOR loops (999 external * 10 internal) - 9990 times of INSTR execution the code will not find a match yet. Only with lngIndex = 1000 and lngItemIndex = 1 will it find a match.

2. I don't understand this

Code:

lngNDSRowIndex = lngItemIndex + 1
…
varOverlay_Data(lngRecordIndex, lngFldIndex + 1) = varNDS_Data(lngNDSRowIndex, lngFldIndex)

In my opinion it should be

Code:

lngNDSRowIndex = lngItemIndex
…
varOverlay_Data(lngRecordIndex, lngFldIndex + 1) = varNDS_Data(lngNDSRowIndex, lngFldIndex)

or more simply

Code:

varOverlay_Data(lngRecordIndex, lngFldIndex + 1) = varNDS_Data(lngItemIndex, lngFldIndex)

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to Remove the subtotal columns in a sheet	Marcia	Excel	3	12-01-2023 05:48 AM
Relating cells in a row in one sheet to cells in columns on another sheet.	mbesspiata3	Excel	2	01-06-2017 05:42 AM
Create a New Sheet from Existing Sheet with Specific Columns	malam	Excel Programming	1	10-17-2014 10:01 PM
From an XL sheet ,how to keep the group of columns which match with other XL sheet	Zubairkhan	Excel	2	03-04-2014 10:57 PM
Removing columns within sheet	shabbaranks	Excel	2	09-11-2012 05:03 AM