Copy ID Data based on converting date series into start date and end date

[decent_boy]

Hi,
I have data sheet with Numbers in col A , ID in Col B and Dates in Col C I Just need a macro to copy each Number and convert its dated into start date and end date. I am attached here images of Data Sheet and Result Sheet.

 

[mumps]

It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Do you want the result to replace the current data or do you want it on a separate sheet?

 

[decent_boy]

It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Do you want the result to replace the current data or do you want it on a separate sheet?

Please find below as required

Book5
	A	B	C
1	Numbers	ID	Date
2	00012345	22	1/3/2022
3	00012345	22	1/3/2022
4	00012345	22	1/3/2022
5	00012345	22	1/3/2022
6	00012345	22	1/5/2022
7	00012345	22	1/5/2022
8	00012345	22	1/6/2022
9	00012345	22	1/6/2022
10	00012345	22	1/6/2022
11	00012345	22	1/6/2022
12	00012345	22	1/6/2022
13	00012345	22	1/6/2022
14	00012345	22	1/6/2022
15	00023456	22	1/3/2022
16	00023456	22	1/3/2022
17	00023456	22	1/3/2022
18	00023456	22	1/3/2022
19	00023456	22	1/4/2022
20	00023456	22	1/4/2022
Data

Book5
	A	B	C	D
1	Number	ID	Start Date	End Date
2	00012345	22	1/3/2022	1/6/2022
3	00023456	22	1/3/2022	1/4/2022
Result

 

[mumps]

Try:

Sub CopyIDData()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcWS As Worksheet, desWS As Worksheet, sDate As Range, eDate As Range
    Set srcWS = Sheets("Data")
    Set desWS = Sheets("Result")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Set sDate = srcWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlNext).Offset(, 2)
                Set eDate = srcWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlPrevious).Offset(, 2)
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4) = Array(v(i, 1), v(i, 2), sDate, eDate)
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[decent_boy]

Try:

Sub CopyIDData()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcWS As Worksheet, desWS As Worksheet, sDate As Range, eDate As Range
    Set srcWS = Sheets("Data")
    Set desWS = Sheets("Result")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Set sDate = srcWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlNext).Offset(, 2)
                Set eDate = srcWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlPrevious).Offset(, 2)
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4) = Array(v(i, 1), v(i, 2), sDate, eDate)
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

Thanks Mumps for your reply and given above codes are working fine but I have just 3 issues on result sheet that 1 is that i have got 5 lacs rows data where these codes are taking too much to show result and 2nd is start and end date format and third one is that 000 are removed from numbers in result sheet

 

[mumps]

i have got 5 lacs rows data

What do you mean by this?
Format columns C and D in the Result sheet to match your desired format.
Try this version:

Sub CopyIDData()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcWS As Worksheet, desWS As Worksheet, sDate As Range, eDate As Range
    Set srcWS = Sheets("Data")
    Set desWS = Sheets("Result")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Set sDate = srcWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlNext).Offset(, 2)
                Set eDate = srcWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlPrevious).Offset(, 2)
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4) = Array("'" & v(i, 1), v(i, 2), sDate, eDate)
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[decent_boy]

What do you mean by this?
Format columns C and D in the Result sheet to match your desired format.
Try this version:

Sub CopyIDData()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcWS As Worksheet, desWS As Worksheet, sDate As Range, eDate As Range
    Set srcWS = Sheets("Data")
    Set desWS = Sheets("Result")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(v)
            If Not .exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Set sDate = srcWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlNext).Offset(, 2)
                Set eDate = srcWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlPrevious).Offset(, 2)
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4) = Array("'" & v(i, 1), v(i, 2), sDate, eDate)
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

Thank so much Momps for your support.

 

[mumps]

You are very welcome.

 

[decent_boy]

You are very welcome.

I have run these code 13 minutes before on 5 lacs row which is still running. Do you think that is there any other fastest way to get required result

 

[decent_boy]

Mumps. I am facing following issue in result can you please check this

Book8
	A	B	C
1	Numbers	ID	Date
2	12345	22	1/3/2022
3	12345	22	1/3/2022
4	12345	22	1/3/2022
5	12345	22	1/3/2022
6	12345	22	1/5/2022
7	12345	22	1/5/2022
8	12345	22	1/6/2022
9	12345	22	1/6/2022
10	12345	22	4/2/2022
11	12345	22	4/2/2022
12	12345	22	4/2/2022
13	12345	22	4/3/2022
14	12345	22	4/3/2022
15	12345	22	4/4/2022
16	23456	22	1/3/2022
17	23456	22	1/3/2022
18	23456	22	1/3/2022
19	23456	22	1/4/2022
20	23456	22	1/4/2022
Data

Book8
	A	B	C	D	E
1	Number	ID	Start Date	End Date
2	12345	22	1/3/2022	4/4/2022	Incorrect
3	23456	22	1/3/2022	1/4/2022
4
5
6
7	12345	22	1/3/2022	1/6/2022	Correct
8	12345	22	4/2/2022	4/4/2022
Result