MACRO/VBA - Extract unique values to different worksheet that meets a criteria

[acerlaptop]

Hi everyone. (NOTE: Due to company privacy policy, attaching file is BLOCKED by out IT Dept)

I have to Worksheets.

Worksheet 1 = Summary
Worksheet 2 = Data

What I want is to update Summary, for example starting at cell L47 down until L56 (all blank cells). I want to put values in there from DATA worksheet that passes certain criteria, that is, DATA (Column A) = SUMMARY (A1).

Also, DATA (column F) contains different codes. So basically, Summary (L47) will be updated with unique values from DATA (column F) that passes the criteria. As long as there is a unique value from DATA (column F) that passes the criteria, the code will list it down to SUMMARY (L47), and if L47 to L56 are all full but there are still unique value to paste, then the code will add rows.

 

[acerlaptop]

I will modify the code to insert rows before updating past row 56.
I can also add code to put TEMP in column A of any added rows so the next time the code is run it will delete those rows before continuing.
Does TEMP appear in any cells in column A in your Summary worksheet?

Do you have any code the refers to cells? If so, it will not recognize that extra rows will added and that may cause a problem. Formulas should adjust if more rows are added, but there could be some complications there as well.

TEMP don't appear in any cell in any sheet of my workbook but you can't use Column A, use Column AQ instead. And there is really no code that refers to cells in Summary sheet. It's just values updating. But to add though, after you add rows, there is a formula above the row (on different column) the row should also contain the same formulas and format from column A to Column AO of the added row.

Also, I don't know if this will help, but I think you can actually delete directly the extra row without using TEMP by counting "lastrow" of Column L and delete the excess of "lastrow" vs L57 using "IF" before clearing the contents of Column L (47 to Lastrow).

 

[pbornemeier]

Try this. In testing I found that it is not case sensitive. If that is a problem, let me know and I will attempt a workaround. Which needs a guaranteed unused cell in your workbook).

Option Explicit

Sub CopyData()
    'https://www.mrexcel.com/board/threads/macro-vba-extract-unique-values-to-different-worksheet-that-meets-a-criteria.1124420/
    
    Dim lSummaryLLastRow As Long
    Dim lDataALastRow As Long
    Dim lWriteRow As Long
    Dim lRowIndex As Long
    Dim sDataFEntry As String
    Dim sTemp As String
    
    Dim sMatchCriterion As String
    
    sMatchCriterion = Worksheets("Summary").Range("A1").Text
    
    With Worksheets("Summary")
        lSummaryLLastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
        If lSummaryLLastRow > 56 Then
            'Delete extra rows that were added during last run
            .Range("A57:AO" & lSummaryLLastRow).Delete Shift:=xlUp
        End If
        .Range("L46:L56").ClearContents
        lSummaryLLastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
        If lSummaryLLastRow < 46 Then lSummaryLLastRow = 46
    End With
    
    lWriteRow = lSummaryLLastRow + 1
    With Worksheets("Data")
        lDataALastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        For lRowIndex = 2 To lDataALastRow
            If .Cells(lRowIndex, 1).Value = sMatchCriterion Then
                sDataFEntry = .Cells(lRowIndex, 6).Value
                With Worksheets("Summary")
                    If Application.WorksheetFunction.CountIf(.Range(.Cells(47, 12), .Cells(lWriteRow, 12)), CStr(sDataFEntry)) = 0 Then
                        'Found new unique value
                        If lWriteRow > 56 Then
                            'Copy row 56 to next write row to include formulas
                            .Range("A56:AO56").Copy Destination:=.Cells(lWriteRow, 1)
                        End If
                        'Update column L of Row lWriterow with the new unique value
                        .Cells(lWriteRow, 12).Value = sDataFEntry
                        'Increment write row
                        lWriteRow = lWriteRow + 1
                    End If
                End With
            End If
        Next
    End With
End Sub