Extract values from each cell to a separate sheet-CodePudding

Have been needing this for my automation, and kinda stuck with this part of the code. A have a file with a few sheets, I need to extract values from each not empty cell into a column on another sheet.

Would be awesome if while doing that duplicates can be removed as well.

At the moment I use the following code, but it infinitely loops, and I don't see the way how to break the loop since all the events are being used in the body of the code.

Range of where the cells are being looked for on both sheets are different, that is why I used .End(xlUp). to define the last row with values in cells. Also I cannot use empty cells as a trigger for stopping the loop, because there are plenty of empty cell along the way and between cells with values.

Sub updt()
Dim ws As Worksheet, currWs As Worksheet, Lng As Integer, rng As Range
Set ws = wb.Worksheets("Sheet1") 'the source sheet
Set currWs = Sheets("Sheet2") 'the destination sheet
Lng = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A2:A" & Lng)
For Each c Lng rng
If WorksheetFunction.CountIf(currWs.Range("A:A"), c.Value) = 0 Then
currWs.Range("A" & currWs.Cells(Rows.Count, 1).End(xlUp).Row)(2) = c.Value
End If
Next
End Sub

Would appreciate your help, could be fixed above text or maybe there is another solution I can apply to solve this problem.

CodePudding user response：

Update Column With Unique Non-Existing Values From a Column of Another Worksheet Using a Dictionary

To avoid further complications, no arrays are used.

Option Explicit

Sub UpdateWorksheet()
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet, calculate the last row
    ' and reference the source column range.
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    Dim srg As Range: Set srg = sws.Range("A2:A" & slRow)
    
    ' Reference the destination worksheet and calculate the last row.
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
    
    ' Define a dictionary (object).
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    ' Declare variables.
    Dim cCell As Range
    Dim cKey As Variant
    
    ' Write the unique values from the destination column range
    ' to the dictionary.
    If dlRow > 1 Then ' 1 means 'first row - 1' i.e. '2 - 1'
        Dim drg As Range: Set drg = dws.Range("A2:A" & dlRow)
        For Each cCell In drg.Cells
            cKey = cCell.Value
            If Not IsError(cKey) Then ' exclude error values
                If Len(cKey) > 0 Then ' exclude blanks
                    dict(cKey) = Empty
                End If
            End If
        Next cCell
    End If
    
    ' Add the unique values from the source column range
    ' to the dictionary.
    For Each cCell In srg.Cells
        cKey = cCell.Value
        If Not IsError(cKey) Then ' exclude error values
            If Len(cKey) > 0 Then ' exclude blanks
                dict(cKey) = Empty
            End If
        End If
    Next cCell
    
    ' Check if the dictionary is empty.
    If dict.Count = 0 Then
        MsgBox "No valid values found.", vbCritical
        Exit Sub
    End If
    
    ' Clear the previous values from the destination first cell to the bottom
    ' of the worksheet.
    Dim dCell As Range: Set dCell = dws.Range("A2")
    With dCell
        .Resize(dws.Rows.Count - .Row   1).ClearContents
    End With
    
    ' Write the unique values from the dictionary to the destination worksheet.
    For Each cKey In dict.Keys
        dCell.Value = cKey ' write
        Set dCell = dCell.Offset(1) ' reference the cell below
    Next cKey
    
    ' Inform.
    MsgBox "Worksheet updated.", vbInformation

End Sub

CodePudding user response：

You might want to use AdvancedFilter:

Option Explicit

Sub Copy_Advanced()
    Dim ws As Worksheet, currWs As Worksheet, Lng As Integer, rng As Range
    Set ws = Worksheets("Sheet1") 'the source sheet
    Set currWs = Sheets("Sheet2") 'the destination sheet
    Lng = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = ws.Range("A1:A" & Lng)

    ws.Range("D1").Value = ws.Range("A1").Value
    ws.Range("D2") = ">0"

    ws.Range(rng.Address).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=ws.Range("D1:D2"), _
        CopyToRange:=currWs.Range("A1"), _
        Unique:=True
End Sub