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.

 

[pbornemeier]

Option Explicit

'I took this:
'  As long as there is a unique value from DATA (column F) that passes the criteria, the code will list...
'to mean that if the value from data column F is already in any cells under L46 on the summary page, don't copy it

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 sMatchCriterion As String
    
    sMatchCriterion = Worksheets("Summary").Range("A1").Text
    
    With Worksheets("Summary")
        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)), sDataFEntry) = 0 Then
                        .Cells(lWriteRow, 12).Value = sDataFEntry
                        lWriteRow = lWriteRow + 1
                    End If
                End With
            End If
        Next
    End With
    
End Sub

 

[acerlaptop]

Option Explicit

'I took this:
'  As long as there is a unique value from DATA (column F) that passes the criteria, the code will list...
'to mean that if the value from data column F is already in any cells under L46 on the summary page, don't copy it

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 sMatchCriterion As String
   
    sMatchCriterion = Worksheets("Summary").Range("A1").Text
   
    With Worksheets("Summary")
        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)), sDataFEntry) = 0 Then
                        .Cells(lWriteRow, 12).Value = sDataFEntry
                        lWriteRow = lWriteRow + 1
                    End If
                End With
            End If
        Next
    End With
   
End Sub

Will this code add another row if all row in my example are already occupied? then delete it again after so that it reverts back to the original number of rows?

Thanks

 

[pbornemeier]

The code will paste unique values in the next blank cell in column L. It will not delete any rows. If rows were deleted, you would never get a chance to see them.

 

[acerlaptop]

The code will paste unique values in the next blank cell in column L. It will not delete any rows. If rows were deleted, you would never get a chance to see them.

What I mean is that L47 down until L56 is the only available cell. So if there is another unique value and L47 down until L56 are full, then insert row then delete it again afterwards for the next report update.

 

[pbornemeier]

If you want to clear the L47 and below before checking again, replace:

    With Worksheets("Summary")
        lSummaryLLastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
        If lSummaryLLastRow < 46 Then lSummaryLLastRow = 46
    End With

with

    With Worksheets("Summary")
        lSummaryLLastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
        If lSummaryLLastRow > 47 Then .range("L47:L" &  lSummaryLLastRow).Cells.ClearContents
    End With

If you want to clear only L57 and below use:

    With Worksheets("Summary")
        lSummaryLLastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
        If lSummaryLLastRow > 56 Then .range("L57:L" &  lSummaryLLastRow).Cells.ClearContents
    End With

 

[acerlaptop]

If you want to clear the L47 and below before checking again, replace:

    With Worksheets("Summary")
        lSummaryLLastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
        If lSummaryLLastRow < 46 Then lSummaryLLastRow = 46
    End With

with

    With Worksheets("Summary")
        lSummaryLLastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
        If lSummaryLLastRow > 47 Then .range("L47:L" &  lSummaryLLastRow).Cells.ClearContents
    End With

If you want to clear only L57 and below use:

    With Worksheets("Summary")
        lSummaryLLastRow = .Cells(.Rows.Count, 12).End(xlUp).Row
        If lSummaryLLastRow > 56 Then .range("L57:L" &  lSummaryLLastRow).Cells.ClearContents
    End With

Hi,

What I mean is that there are only 10 cell from L46 to L57. So if there are 11 unique values, add one row to accommodate the extra unique value. then delete the extra row after the process.

 

[pbornemeier]

The original code would add as many rows as necessary then stop.

If I added more code to the original code to delete the rows below L57, then you would never see them.

Putting any of the code from post 6 into the following will create another sub that will clear the indicated portion of the worksheet:

Sub ClearResults()

    Dim lSummaryLLastRow  as Long

    'Insert one of the examples from post 6 here


End Sub

 

[acerlaptop]

The original code would add as many rows as necessary then stop.

If I added more code to the original code to delete the rows below L57, then you would never see them.

Putting any of the code from post 6 into the following will create another sub that will clear the indicated portion of the worksheet:

Sub ClearResults()

    Dim lSummaryLLastRow  as Long

    'Insert one of the examples from post 6 here


End Sub

It doesn't add rows. It overrides the value in L57 and beyond. Because this is a template, any cell outside L47 to L56 has values that should never be altered. So what I actually need is a code that if the unique values goes beyond L56, it will add row so that it will not override the values in L57. Then, delete the extra rows after the process because once I change the value of the criteria, there will be other set of unique values, and the default template for unique values is only from L47 to L56.

 

[pbornemeier]

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.