Extract unique string values between two dates VBA

[kuldeepjainesl]

I have data with strings in one column and date in another column. i want to extract unique string between given dates . i am able to achieve this by formula but as the data size is huge, i am preferring VBA for optimum performance.

I also searched and found the VBA which extract the unique from the selected data but this do not serve the purpose a i need.

 

[AlanSidman]

Option Explicit

Sub afoo()
    Dim s1 As Worksheet
    Dim s3 As Worksheet
    Set s1 = Sheets("Sheet1")
    Set s3 = Sheets("Sheet3")
    Dim i As Long, lr As Long, lr3 As Long
    lr = s1.Range("A" & Rows.Count).End(xlUp).Row
    Dim Dstart As Date
    Dim Dend As Date
    Dstart = s1.Range("e2").Value
    Dend = s1.Range("D2").Value
    With s1
        For i = 2 To lr
            lr3 = s3.Range("A" & Rows.Count).End(xlUp).Row
            If .Range("B" & i) >= Dstart And .Range("B" & i) <= Dend Then
                .Range("A" & i & ":B" & i).Copy s3.Range("A" & lr3 + 1)
            End If
        Next i
    End With
    MsgBox "completed"
End Sub

Once you run this, you can then run an Advanced filter for Unique Values. You will need to make sure that you have a Sheet3 already part of your workbook.

 

[kuldeepjainesl]

Thank you Alen but this do not serve the purpose.
I need to have the unique value available in column a between two dates automatically so that further formula can work without a user to manually copy paste.

 

[NARAYANK991]

Hi ,

Are your given dates in cells D2 and E2 ?

Why does D2 have a date 01-Dec-2016 , while E2 has a date 05-May-2016 ?

How do you want the output , and where should it be ?

Suppose we take the dates 03-01-2015 and 07-01-2015 , the unique values between these two dates , including both dates , are :

A , AA , AC , AD , AR and AS

How do you want these output ?

Narayan

 

[kuldeepjainesl]

Rightly pointed out. Date are reverse and its a Typo error. D2 will always have smaller date then E2. The output must be pasted on C column of a different sheet (in this Case Sheet2). The earlier all the value to be cleared before pasting as the new values may be less then existing list of values.

 

[kuldeepjainesl]

Narayank, it would a added help is you can add a line of code to refer a dynamic range indicating the data in column A and B. i will comment these line and will use whenever required. Hope this can be done.

Many time is required to refer range in place of method

 Range("A" & Rows.Count).End(xlUp).Row

 

[Chihiro]

Something like below? This assumes Windows machine.

Sub Demo()
Dim myArr, i As Long
myArr = Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value

With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(myArr)
        If myArr(i, 2) >= [D2] And myArr(i, 2) <= [E2] Then
            .Item(myArr(i, 1)) = 1
        End If
    Next
    [C2].Resize(.Count) = Application.Transpose(.Keys)
End With
End Sub

 

[kuldeepjainesl]

There is one thing to be modified as the code is not clearing the existing data in "C" column. if the data generated is less then existing then all further processing will go wrong.

Another requirement is to be able to paste this range in other worksheet as we are pasting in "C" column of same worksheet.

 

[Hui]

This will solve both problems

It needs to be in a code module not a worksheet module

Sub Demo()
Dim myArr As Variant
Dim i As Long
Dim wsh As String
Dim LR As Long

Worksheets("Sheet1").Activate
myArr = Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value

wsh = "Sheet1" 'Set the destination Worksheet name here

LR = Worksheets(wsh).Range("C" & Rows.Count).End(xlUp).Row
Worksheets(wsh).Range("C2:C" & LR).ClearContents 'Clear existing area

Set dict = CreateObject("Scripting.Dictionary")

stDate = CDate(Sheet1.Range("D2"))
enDate = CDate(Sheet1.Range("E2"))

With dict
  For i = 1 To UBound(myArr)
  If myArr(i, 2) >= sDate And myArr(i, 2) <= enDate Then
  If Not dict.Exists(myArr(i, 1)) Then
  .Add myArr(i, 1), 1
  End If
  End If
  Next i
  
  Worksheets(wsh).Range("C2").Resize(.Count) = Application.Transpose(.Keys)

End With
End Sub

 

[kuldeepjainesl]

Worked, Thanks a lot Hui