Compare Lists & Copy Data

Hello,

I need some help with a macro that is working in a very large data base, Im attaching a dummy workbook to assist.

I have two list one with just Z#'s and one with Z#'s and information, I need this macro to reference the list of numbers and if they have a match to copy them. It gets a little complicated because the first 8 digits are unique and there is a possibility the last two change.

IE
Z1234567800
Z1234567801
Z1234567802
Z1234567803

The first is like the master record and the subsequent #'s are attached to it changing the last two digits. The list will only contain the the Z# ending in 00 but I need to pull all the Z#'s that are associated with the first 8 digits.

I tried using an auto filter macro with a bunch of And operators but it didnt work

Please let me know if I can awnser any questions that will help with this.

Thank you

Hello itsnick,

Where do you want the information copied to - a new worksheet? Is the entire row of the database to copied if there is match?

Hello itsnick,

Here is a preliminary workbook. The results that match are copied onto the "Results" worksheet. There is a command button on this sheet to run the macro. Here is the macro...

Sub MatchData()

  Dim Cell As Range
  Dim DBWks As Worksheet
  Dim DstWks As Worksheet
  Dim Key As Variant
  Dim Keys As Variant
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Znums As Object
  
    R = 1
    Set DBWks = Worksheets("Database")
    Set DstWks = Worksheets("Results")
    
     Set Znums = CreateObject("Scripting.Dictionary")
     Znums.CompareMode = vbTextCompare
     
     Set RegExp = CreateObject("VBScript.RegExp")
     RegExp.Pattern = "(\w\d{8})(\d{2})"
     
     Set Rng = Worksheets("List").Range("A1")
     Set RngEnd = Rng.Parent.Cells(Rows.Count, Rng.Column).End(xlUp)
     Set Rng = IIf(RngEnd.Row > Rng.Row, Rng.Parent.Range(Rng, RngEnd), Rng)
     
       For Each Cell In Rng
         Key = Trim(Cell.Text)
         If Key <> "" Then
           If Not Znums.Exists(Key) Then Znums.Add Key, ""
         End If
       Next Cell
       
       Set Rng = DBWks.Range("A1")
       Set RngEnd = DBWks.Cells(Rows.Count, Rng.Column).End(xlUp)
       Set Rng = IIf(RngEnd.Row > Rng.Row, DBWks.Range(Rng, RngEnd), Rng)
       
       DstWks.Cells.ClearContents
       C = DBWks.Cells(1, Columns.Count).End(xlToLeft).Column
       
         For Each Cell In Rng
           X = RegExp.Test(Cell.Text)
           If RegExp.Test(Cell.Text) Then
              Key = Trim(RegExp.Replace(Cell.Text, "$1" & "00"))
              If Znums.Exists(Key) Then
                 DstWks.Cells(R, "A").Resize(1, C) = Cell.EntireRow.Value
                 R = R + 1
              End If
            End If
         Next Cell
              
    Set Znums = Nothing
    Set RegExp = Nothing
    
End Sub

Hello itsnick,

The macro does not sort the data. The dictionary is loaded with the data from the List worksheet. The data is copied based the list the order's first 8 digits from "A1" down.. Did you want the sorted in a particular order?

Hello itsnick,

The macro should not be changing the order. It follows the order of List worksheet. The operation is quite simple.

1. The Dictionary is loaded with the Z numbers from the worksheet "List"
2. All the values from column "A" on the "Database" are placed in a Range object variable.
3. The "Results" worksheet is cleared.
4. Each cell in this range is then tested using the Regular Expression object "RegExp" and if it is a Z number then the last 2 digits are replaced with "00". The entire row from the "Database" worksheet is then copied to the "Results" worksheet.
5. The Regular Expression and Dictionary objects are then set to 'Nothing" to free the object references and memory.
6. The macro is done.