To get cell Address value of Each Date displayed in a Range

N

NimishK

Well-known Member
Joined
Sep 4, 2015
Messages
688
Hi,
Any ideas how can i get cell address values of EACH dates which are displayed in a range which are in Sheet1
Structure of sheet1
[TABLE="width: 539"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD] B[/TD]
[TD]C[/TD]
[TD] D[/TD]
[TD]E[/TD]
[TD] F[/TD]
[TD]G[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]abcd[/TD]
[TD="align: right"]01-01-2019[/TD]
[TD]300[/TD]
[TD="align: right"]02-01-2019[/TD]
[TD]400[/TD]
[TD="align: right"]03-01-2019[/TD]
[TD]500[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD]xyz[/TD]
[TD="align: right"]03-01-2019[/TD]
[TD]200[/TD]
[TD="align: right"]03-01-2019[/TD]
[TD]100[/TD]
[TD="align: right"]05-01-2019[/TD]
[TD]150[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[TD]lmnp[/TD]
[TD="align: right"]04-01-2019[/TD]
[TD]100[/TD]
[TD="align: right"]06-01-2019[/TD]
[TD]600[/TD]
[TD="align: right"]07-01-2019[/TD]
[TD]700[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[TD]excl[/TD]
[TD="align: right"]08-01-2019[/TD]
[TD]150[/TD]
[TD="align: right"]08-01-2019[/TD]
[TD]0[/TD]
[TD="align: right"]08-01-2019[/TD]
[TD]250[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]dfert[/TD]
[TD="align: right"]07-01-2019[/TD]
[TD]300[/TD]
[TD="align: right"]09-01-2019[/TD]
[TD]400[/TD]
[TD="align: right"]10-01-2019[/TD]
[TD]200[/TD]
[/TR]
</tbody>[/TABLE]

Code: 
Sub GetCellAddressofDates()
Dim Dn As Range, rng As Range, Col As Variant
Dim nRng As Range
Dim Dic As Object, Dt As Variant
Dim Q
  Col = Array(2, 4, 6) 
   With Sheets("Sheet1")
    Set rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    Set Dic = CreateObject("Scripting.Dictionary")   
        Dic.CompareMode = 1   
  For Each Dt In Col
    Set rng = Range(Cells(1, Dt), Cells(Rows.Count, Dt).End(xlUp))
        For Each Dn In rng
            If Not Dic.exists(Dn.Value) Then
                Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            End If
        
        If Not Dic(Dn.Value).exists(Dn.Row) Then
                Dic(Dn.Value).Add (Dn.Row), Nothing
        End If


    Next Dn
   Next Dt
   
   Dim k As Variant, nDt As Date, Ldt As Date, p As Variant, c As Long


   c = 1
   With Sheets("Sheet2")
    If txtFromDate.Value <> "" And txtToDate.Value <> "" Then
   
    For Each k In Dic.Keys
     If Dic.exists(CDate(txtFromDate.Value)) And Dic.exists(CDate(txtToDate.Value)) Then
        If k >= CDate(txtFromDate.Value) And k <= CDate(txtToDate.Value) Then
          For Each p In Dic(k)
               c = c + 1
               .Cells(c, "A") = k   
               .Cells(c, "B") = p   
                .Cells(c, "C") = [COLOR=#ff0000][B]'to get cell address of value K which is in Sheet1
[/B][/COLOR]           Next p
        End If
        ElseIf Dic.exists(CDate(txtFromDate.Text)) Then
            If k >= CDate(txtFromDate.Text) Then
                For Each p In Dic(k)
                    c = c + 1
                    .Cells(c, "a") = k  
                    .Cells(c, "b") = p  
                    .Cells(c, "C") = [COLOR=#ff0000][B]'to get cell address of value K[/B]
[/COLOR]                Next p
            End If
        End If
 
Next k
[Structre and code adopted from MrExcel - thread 1088850]
Thanks
NimishK
 
Last edited:
Sort by date Sort by votes
Dim i as long, dim j as long ' is correct

Before executing the macro you have to put on Sheet2 in the column C the date format.

My results go to row 16.


Surely you have cells with blank spaces in your sheet1 below the last cell in column A. Delete those cells and execute the macro again.
 
Upvote 0

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Surely you have cells with blank spaces in your sheet1 below the last cell in column A. Delete those cells and execute the macro again.
Click to expand...
Infact i deleted full blank rows after the last cell in col A but values from row 17 are repeated as post #10 . Tried your code 7-10 times. Really Nothing Happened.
Will it be possible to control blank spaces so that values from row 17 are not repeated
 
Last edited:
Upvote 0
I do not know how you have the data, it works for me until the 16th. it is possible to review the blanks with the macro, but the macros will always have their limitations, such as protected sheets, hidden sheets, sheets with tables, filtered data, hidden columns, cell formats, merged cells, etc. I suggest you try the macro in a new book only with the example data that you put, since I can not see how your data is and solve each situation described above.
 
Upvote 0
Hi Yes You were absolutely right i had to delete other sub-routines and subroutine as per #1 to check your valuable suggestion. Worked Perfectly
But was wondering as per #post 1 there are two textboxes txtFromDate.text and txtToDate.Text where the dates entered and those dates are displayed.
Any possibility with your suggestion how to get the cell address of each From date uptill To Date


File attached
https://www.dropbox.com/s/ngn89toysu97vi8/DateMis-Nim.xlsm?dl=0
 
Upvote 0
I'm not sure what you want to do with the dates.
Do you want to filter by dates?
Or do you want to mark the range from txtFromDate to txtToDate?



Important: The particular search of a date, using the find method, requires that the format of the date in the cell be dd / mm / yyyy.

Try the following on my file:

Code: 
Option Explicit
Dim fromDate As Date, toDate As Date

Private Sub UserForm_Initialize()
Load UserForm1
UserForm1.Show vbModeless
End Sub

Private Sub txtFromDate_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If txtFromDate.Value = vbNullString Then
    Exit Sub
ElseIf Not IsDate(txtFromDate.Value) Then
    Cancel = True
    MsgBox "Invalid date, please re-enter", vbCritical

    txtFromDate.Value = vbNullString
    txtFromDate.SetFocus
    Exit Sub
End If
fromDate = DateSerial(Year(Date), Month(Date), Day(Date))
[COLOR=#ff0000]txtFromDate.Value = Format(CDate(txtFromDate.Value), "dd/mm/yyyy")[/COLOR]

End Sub

Private Sub txtToDate_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If txtToDate.Value = vbNullString Then
    Exit Sub
ElseIf Not IsDate(txtToDate.Value) Then
    Cancel = True
    MsgBox "Invalid date, please re-enter", vbCritical

    txtToDate.Value = vbNullString
    txtToDate.SetFocus
    Exit Sub
End If
toDate = DateSerial(Year(Date), Month(Date), Day(Date))
[COLOR=#ff0000]txtToDate.Value = Format(CDate(txtToDate.Value), "dd/mm/yyyy")[/COLOR]

End Sub
Private Sub cmdAllInputDates_Click()
   Call get_cell_Address
End Sub

Sub get_cell_Address()
     'DanteAmor https://www.mrexcel.com/forum/excel-questions/1095288-get-cell-address-value-each-date-displayed-range.html
     Dim o As Worksheet, d As Worksheet, n As Long, j As Long, i As Long
     Dim b As Range, c As Range
     
     Application.ScreenUpdating = False
     Set o = Sheets("Sheet1")    'origen
     Set d = Sheets("Sheet2")    'destination
[COLOR=#ff0000]     d.Columns("C").NumberFormat = "dd/mm/yyyy"[/COLOR]
     d.Rows("2:" & Rows.Count).ClearContents
     d.Columns("F").Interior.ColorIndex = xlNone
     n = 2
     For j = 2 To o.Cells(2, Columns.Count).End(xlToLeft).Column Step 2
      For i = 2 To o.Cells(Rows.Count, 1).End(xlUp).Row
       d.Cells(n, "A").Resize(, 6) = Array(n, o.Cells(i, 1), o.Cells(i, j), o.Cells(i, j).Offset(, 1), i, o.Cells(i, j).Address(0, 0))
       n = n + 1
      Next
     Next
     d.Range("B2:F2").Resize(n).Sort key1:=d.Range("C2"), order1:=xlAscending, key2:=d.Range("b2"), order2:=xlAscending, Header:=xlNo
        If txtFromDate <> "" And IsDate(txtFromDate) Then
            If txtToDate <> "" And IsDate(txtToDate) Then
                Set b = d.Range("C:C").Find(txtFromDate, LookIn:=xlValues, lookat:=xlWhole)
                Set c = d.Range("C:C").Find(txtToDate, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious)
                If Not b Is Nothing Then
                    If Not c Is Nothing Then
                        d.Range(d.Cells(b.Row, "F"), d.Cells(c.Row, "F")).Interior.ColorIndex = 6
                        End If
                End If
            End If
        End If
 End Sub

https://www.dropbox.com/s/utjr3eotnvk8mog/DateMis-Nim dam.xlsm?dl=0
 
Last edited:
Upvote 0
DanteAmor Thankx
Yes, it is Filtering of dates
i.e to get the list of Dates or display the range of date in destination sheet between fromDate and to Date
As per your eg you have directly put dates 03-01-2019 in txtFromdate .text and 08-01-2019 in txtToDate.text in uf
So in that case it should display in following though you have hilited in F col with color index
[TABLE="width: 0"]
<tbody>[TR]
[TD]4[/TD]
[TD]abcd[/TD]
[TD]03-01-2019[/TD]
[TD]500[/TD]
[TD]2[/TD]
[TD]F2[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]xyz[/TD]
[TD]03-01-2019[/TD]
[TD]200[/TD]
[TD]3[/TD]
[TD]B3[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]xyz[/TD]
[TD]03-01-2019[/TD]
[TD]100[/TD]
[TD]3[/TD]
[TD]D3[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]lmnp[/TD]
[TD]04-01-2019[/TD]
[TD]100[/TD]
[TD]4[/TD]
[TD]B4[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]xyz[/TD]
[TD]05-01-2019[/TD]
[TD]150[/TD]
[TD]3[/TD]
[TD]F3[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]Lmnp[/TD]
[TD]06-01-2019[/TD]
[TD]600[/TD]
[TD]4[/TD]
[TD]D4[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]Dfert[/TD]
[TD]07-01-2019[/TD]
[TD]300[/TD]
[TD]6[/TD]
[TD]B6[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]Lmnp[/TD]
[TD]07-01-2019[/TD]
[TD]700[/TD]
[TD]4[/TD]
[TD]F4[/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD]Excl[/TD]
[TD]08-01-2019[/TD]
[TD]150[/TD]
[TD]5[/TD]
[TD]B5[/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]Excl[/TD]
[TD]08-01-2019[/TD]
[TD]0[/TD]
[TD]5[/TD]
[TD]D5[/TD]
[/TR]
[TR]
[TD]14[/TD]
[TD]Excl[/TD]
[TD]08-01-2019[/TD]
[TD]250[/TD]
[TD]5[/TD]
[TD]F5[/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...

In other words if txtFromdate .text ‘s input is 01-01-2019 and txttodate .text ‘s input is 05-01-2019
Then to display
[TABLE="width: 0"]
<tbody>[TR]
[TD]2[/TD]
[TD]abcd[/TD]
[TD]01-01-2019[/TD]
[TD]300[/TD]
[TD]2[/TD]
[TD]B2[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]abcd[/TD]
[TD]02-01-2019[/TD]
[TD]400[/TD]
[TD]2[/TD]
[TD]D2[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]abcd[/TD]
[TD]03-01-2019[/TD]
[TD]500[/TD]
[TD]2[/TD]
[TD]F2[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]xyz[/TD]
[TD]03-01-2019[/TD]
[TD]200[/TD]
[TD]3[/TD]
[TD]B3[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]xyz[/TD]
[TD]03-01-2019[/TD]
[TD]100[/TD]
[TD]3[/TD]
[TD]D3[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]lmnp[/TD]
[TD]04-01-2019[/TD]
[TD]100[/TD]
[TD]4[/TD]
[TD]B4[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]xyz[/TD]
[TD]05-01-2019[/TD]
[TD]150[/TD]
[TD]3[/TD]
[TD]F3[/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...
Important: The particular search of a date, using the find method, requires that the format of the date in the cell be dd / mm / yyyy.
Click to expand...

can't the above be as dd-mmm-yyyy
 
Last edited:
Upvote 0
Try this, and of course, it can be dd-mmm-yyyy


Code: 
Option Explicit
Dim fromDate As Date, toDate As Date


Private Sub UserForm_Initialize()
Load UserForm1
UserForm1.Show vbModeless
End Sub


Private Sub txtFromDate_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If txtFromDate.Value = vbNullString Then
    Exit Sub
ElseIf Not IsDate(txtFromDate.Value) Then
    Cancel = True
    MsgBox "Invalid date, please re-enter", vbCritical


    txtFromDate.Value = vbNullString
    txtFromDate.SetFocus
    Exit Sub
End If
fromDate = DateSerial(Year(Date), Month(Date), Day(Date))
txtFromDate.Value = Format(CDate(txtFromDate.Value), "[COLOR=#0000cd]dd-mm-yyyy[/COLOR]")


End Sub
Private Sub txtToDate_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If txtToDate.Value = vbNullString Then
    Exit Sub
ElseIf Not IsDate(txtToDate.Value) Then
    Cancel = True
    MsgBox "Invalid date, please re-enter", vbCritical


    txtToDate.Value = vbNullString
    txtToDate.SetFocus
    Exit Sub
End If
toDate = DateSerial(Year(Date), Month(Date), Day(Date))
txtToDate.Value = Format(CDate(txtToDate.Value), "[COLOR=#0000cd]dd-mm-yyyy[/COLOR]")


End Sub
Private Sub cmdAllInputDates_Click()
   Call get_cell_Address
End Sub


Sub get_cell_Address()
     'DanteAmor https://www.mrexcel.com/forum/excel-questions/1095288-get-cell-address-value-each-date-displayed-range.html
     Dim o As Worksheet, d As Worksheet, n As Long, j As Long, i As Long
     Dim b As Range, c As Range
     
     Application.ScreenUpdating = False
     Set o = Sheets("Sheet1")    'origen
     Set d = Sheets("Sheet2")    'destination
     d.Columns("C").NumberFormat = "[COLOR=#0000cd]dd-mmm-yyyy[/COLOR]"
     d.Rows("2:" & Rows.Count).ClearContents
     d.Columns("F").Interior.ColorIndex = xlNone
     n = 2
     For j = 2 To o.Cells(2, Columns.Count).End(xlToLeft).Column Step 2
      For i = 2 To o.Cells(Rows.Count, 1).End(xlUp).Row
       d.Cells(n, "A").Resize(, 6) = Array(n, o.Cells(i, 1), o.Cells(i, j), o.Cells(i, j).Offset(, 1), i, o.Cells(i, j).Address(0, 0))
       n = n + 1
      Next
     Next
     d.Range("B2:F2").Resize(n).Sort key1:=d.Range("C2"), order1:=xlAscending, key2:=d.Range("b2"), order2:=xlAscending, Header:=xlNo
     
     Dim lr As Long
     lr = d.Range("A" & Rows.Count).End(xlUp).Row
     For i = lr To 2 Step -1
        If d.Cells(i, "C").Value >= CDate(txtFromDate.Value) And _
           d.Cells(i, "C").Value <= CDate(txtToDate.Value) Then
        Else
            d.Rows(i).Delete
        End If
    Next
End Sub
 
Upvote 0
Just Perfect.:):beerchug:
Thanks DanteAmor for your very quick response and spending your valuable time for this solution.
Also Congrats for posting more than 2400 posts in just span of 5 months.
Thank you so much
NimishK
 
Upvote 0
NimishK said:
Just Perfect.:):beerchug:
Thanks DanteAmor for your very quick response and spending your valuable time for this solution.
Also Congrats for posting more than 2400 posts in just span of 5 months.
Thank you so much
NimishK
Click to expand...

I'm glad to help you. I appreciate your kind comments.
 
Upvote 0
You must log in or register to reply here.

Similar threads

montecarlo2012
  • Question Question
change display from horizontal to vertical
Replies
2
Views
137
montecarlo2012
montecarlo2012
G
  • Question Question
Why does #VALUE error in VBA function occur when creating a ReDim Matrix of Stock prices from a Named Range?
Replies
2
Views
103
Peter_SSs
Peter_SSs
O
  • Solved
VBA Code to Find Duplicate Values in a Range and Add a Number at the End
2
Replies
12
Views
803
OilEconomist
O
R
  • Solved
extract date but exclude Time
Replies
2
Views
455
rikvny02
R
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
832
Agnarr
Agnarr

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top