A Semi automated way to note the IP addresses of things viewing us

A walk through another Summary,
(This time Wednesday 16 July to Wednesday 23 July,
( A week from deletion of top post showthread.php?t=2993/Alan and Clare Testing )

About a week ago I brought all the day measurements together, for the period of about 19 days
28 June – 15 July 2025
https://www.excelfox.com/forum/showt...ll=1#post25073
https://www.excelfox.com/forum/showt...ll=1#post25074
https://www.excelfox.com/forum/showt...ll=1#post25075

Lets do the same for about the week after that , Wednesday/Thursday 16/17 July - Thursday 24 July , which will also be the week after I deleted a Thread which was usually top of the views list, ( showthread.php?t=2993/Alan and Clare Testing )

We need the files from that period: ( or rather we don't*** )

Code:

---



https://app.box.com/s/dp7em0dwgjvfmqh6dupx3pfy24d2zgbt  IPAddressesWatchingExcelFox_Refresh_Thursday 24 July, 2025 15min 4460 217.xls

https://app.box.com/s/ougkv441qjj5ofybcmf12egcu9csff75  IPAddressesWatchingExcelFox_Refresh_Wednesday 23 July 2025 15min 4680 232.xls

https://app.box.com/s/0xwrd8hji3a1vr0ky1mdhm8bjzw9sgp8      ‘IPAddressesWatchingExcelFox_Refresh_Tuesday Evening 22 July 2025 15min 4640 232.xls’

https://app.box.com/s/1ueglq4tp6k0zjsb0zec1mh8c843bt2z    IPAddressesWatchingExcelFox_Refresh_Tuesday 22 July 2025 15min 4700 236.xls

https://app.box.com/s/bo1htufkcw33kvin0vm02yloc1od11sw    IPAddressesWatchingExcelFox_Refresh_Monday Evening 21 July 2025 15min 4600 223.xls

https://app.box.com/s/ihal0jb4tmisvtrq613tezyca52jo10f  IPAddressesWatchingExcelFox_Refresh_Monday 21 July 2025 18min 4693 240.xls

https://app.box.com/s/bu4zvdl5goltidjimsmsbur239j18mvf    IPAddressesWatchingExcelFox_Refresh_Sunday 20 July 2025 15min 223.xls

https://app.box.com/s/kkd0ff0vwken8474qdlqp1cm2q8ip08l  IPAddressesWatchingExcelFox_Sunday 20 July, 2025 225.xls

https://app.box.com/s/4d8hmesm26ai4nmt48v9fu822zw9vb1y  PAddressesWatchingExcelFox_Saturday 19 July, 2025 4745 238.xls

https://app.box.com/s/v9tkfhv30ksge4f7vupspfdessybhknl    IPAddressesWatchingExcelFox_Friday 18 July 2025 4690 235 43min.xls
https://app.box.com/s/5bw48x0ljjeqhz9fmqti9xj1xp554xgz      https://app.box.com/s/jx4r0e93amq58ug1rrvvq42g6b8ud00p    IPAddressesWatchingExcelFox_Friday 18 July 2025 Refresh 235 45min.xls

 https://app.box.com/s/99ycb1igkz3zqadhzudz9kjbf3uxpdqo      IPAddressesWatchingExcelFox_Thurs 17 July 2025_4658 233 36min.xls

https://app.box.com/s/hgf7tqhdmbi8ss3hj408vbe1lxzlwvjf  IPAddressesWatchingExcelFox_Wed 16 July 2025_Gone Clare 4775 239.xls

---

---

OK. So we need the latest RequestsIPsSummary.xls file open and then two possibilities:
_(i) sequentially the files above open, and With each file from above open, we use the codings used already each time to get in the clipboard something to paste manually in the extra two worksheets in the file RequestsIPsSummary.xls
_(ii) use the coding in the next post, which, working on the top left of the ranges in RequestsIPsSummary.xls , then will paste them in the worksheets AllRequests or AllIPs

***I will use _(ii).
I had used _(i) before as I had not yet got all files into RequestsIPsSummary.xls

( For either option, range C:D is cleared initially as it will have them all. I do that by shifting the other columns for the Sat 28 June to 15 July Wednesday. (There were a few columns due to the quirk that the codings to reduce to unique values needed to be done a few times. So I may reconsider that coding later.

IPs and Requests totals Wednesday/Thursday 16/17 July - Thursday 24 July
The coding here is similar to that used the last time ( 28 June – 15 July 2025
https://www.excelfox.com/forum/showt...ll=1#post25073
https://www.excelfox.com/forum/showt...ll=1#post25074
https://www.excelfox.com/forum/showt...ll=1#post25075
I did try a small change initially using xlWhole in place of the xlPart
The coding appeared to take much longer than I remember, almost 3 SchlappenBiers this time. It appeared afterwards that it did not need a second run
But then I changed back to xlPart and it still seemed to take a long time. Second and third runs where needed, or rather did something
I went back and redid 28 June – 15 July 2025 with xlWhole. that seemed to take ages . I must tighten up, that is to say, routinely do a Debug.Print to make a record of when I do such a coding and how long it takes

Code:

---

Sub TimeIt() ' https://www.excelfox.com/forum/showthread.php/3007-A-Semi-automated-way-to-note-the-IP-addresses-of-things-viewing-us?p=25098&viewfull=1#post25098
Dim StTime As Long: Let StTime = Timer
'
'
Debug.Print Int((Timer - StTime) / 60) & "min  " & Format(Now, "ddd dd mmm yyyy hh:nn")
End Sub


---

Requests totals Wednesday/Thursday 16/17 July - Thursday 24 July

This is the final coding used. File uploaded in the next post.

Code:

---

Option Explicit
Sub CopyTLReqToAllReq() ' Copy based on top left selection of range
Dim wsIPs As Worksheet, wsReqs As Worksheet, wsAllReqs As Worksheet, wsAllIPs As Worksheet
 Set wsIPs = ThisWorkbook.Worksheets("IPs"): Set wsReqs = ThisWorkbook.Worksheets("Requests"): Set wsAllReqs = ThisWorkbook.Worksheets("AllRequests"): Set wsAllIPs = ThisWorkbook.Worksheets("AllIPs")
wsReqs.Activate: Dim TL As Range: Set TL = Selection
Dim Lr As Long
 Let Lr = TL.Offset(0, 1).Item(wsAllReqs.Rows.Count).End(xlUp).Row ' This will error if you have not slected first row so that is a good check
Dim rngReq As Range
 Set rngReq = TL.Offset(1, 0).Resize(Lr - 1, 3)
' rngReq.Copy

wsAllReqs.Activate ' Range D:F is the one we paste to
' Let Lr = wsAllReqs.Range("E" & wsAllReqs.Rows.Count & "").End(xlUp).Row
Dim NxtRw As Long: Let NxtRw = wsAllReqs.Range("E" & wsAllReqs.Rows.Count & "").End(xlUp).Row + 1

 rngReq.Copy Destination:=wsAllReqs.Range("D" & NxtRw & "")

wsReqs.Activate
End Sub '
' 16/17 July - Thursday 24 July
Sub SingleReqList()
Dim StTime As Long: Let StTime = Timer
Dim wsIPs As Worksheet, wsReqs As Worksheet, wsAllReqs As Worksheet, wsAllIPs As Worksheet
 Set wsIPs = ThisWorkbook.Worksheets("IPs"): Set wsReqs = ThisWorkbook.Worksheets("Requests"): Set wsAllReqs = ThisWorkbook.Worksheets("AllRequests"): Set wsAllIPs = ThisWorkbook.Worksheets("AllIPs")
Dim Lr As Long
 Let Lr = wsAllReqs.Range("D" & wsAllReqs.Rows.Count & "").End(xlUp).Row

Dim rngReqs As Range
 Set rngReqs = wsAllReqs.Range("D2:F" & Lr & "")

Dim Cnt As Long
    For Cnt = 2 To Lr Step 1
        If Len(wsAllReqs.Range("E" & Cnt & "").Value2) > 255 Then GoTo NxtCnt
        If wsAllReqs.Range("E" & Cnt & "") = "" Or wsAllReqs.Range("E" & Cnt & "") = Empty Or Cnt = Lr Then Exit Sub ' This should happen as we are deleting cells so eventually we will reach the end of the shortened range ( It gets shortened every time a row is deleted. )  If we are doung a second take nd nothing happens we will reach  Lr  but the search range becomes that with  Lr  in it which causes a glitch
    Dim rngFnd As Range, rngSrch As Range
    Set rngSrch = wsAllReqs.Range("E" & Cnt + 1 & ":E" & Lr & "") ' I dont want to be searching the range including the value i am looking for, or I will find it as last, (after getting to the end and then starting again), and delete the fucker
    Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("E" & Cnt & "").Value2, After:=wsAllReqs.Range("E" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
'    Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("E" & Cnt & "").Value2, After:=wsAllReqs.Range("E" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        Do While Not rngFnd Is Nothing
        Let wsAllReqs.Range("D" & Cnt & "") = wsAllReqs.Range("D" & Cnt & "").Value + rngFnd.Offset(0, -1).Value ' Hits
        Let wsAllReqs.Range("F" & Cnt & "") = wsAllReqs.Range("F" & Cnt & "").Value & vbCr & vbLf & " " & rngFnd.Offset(0, 1).Value ' IP addresses making the hits/ requests
        Let wsAllReqs.Range("F" & Cnt & "").WrapText = False
        rngFnd.Offset(0, -1).Resize(1, 3).Delete shift:=xlUp ' Delete duplicate row after adding hits and ip addresses
       
        Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("E" & Cnt & "").Value2, After:=wsAllReqs.Range("E" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
'        Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("E" & Cnt & "").Value2, After:=wsAllReqs.Range("E" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        Loop ' While Not rngFnd = Nothing
NxtCnt:
    Next Cnt

Debug.Print Int((Timer - StTime) / 60) & "min  " & Format(Now, "ddd dd mmm yyyy hh:nn")
End Sub

Sub SortOf()
Dim wsIPs As Worksheet, wsReqs As Worksheet, wsAllReqs As Worksheet, wsAllIPs As Worksheet
 Set wsIPs = ThisWorkbook.Worksheets("IPs"): Set wsReqs = ThisWorkbook.Worksheets("Requests"): Set wsAllReqs = ThisWorkbook.Worksheets("AllRequests"): Set wsAllIPs = ThisWorkbook.Worksheets("AllIPs")
Dim Lr As Long
 Let Lr = wsAllReqs.Range("D" & wsAllReqs.Rows.Count & "").End(xlUp).Row
Dim rngReqs As Range
 Set rngReqs = wsAllReqs.Range("D2:F" & Lr & "")
 rngReqs.Sort Key1:=rngReqs.Columns(1), Order1:=xlDescending
End Sub

---

IPs totals Wednesday/Thursday 16/17 July - Thursday 24 July

Code:

---

Option Explicit
Sub CopyTLIPsToAllIPs() ' Copy based on top left selection of range
Dim wsIPs As Worksheet, wsReqs As Worksheet, wsAllReqs As Worksheet, wsAllIPs As Worksheet
 Set wsIPs = ThisWorkbook.Worksheets("IPs"): Set wsReqs = ThisWorkbook.Worksheets("Requests"): Set wsAllReqs = ThisWorkbook.Worksheets("AllRequests"): Set wsAllIPs = ThisWorkbook.Worksheets("AllIPs")
wsIPs.Activate: Dim TL As Range: Set TL = Selection
Dim Lr As Long
 Let Lr = TL.Offset(0, 1).Item(wsAllReqs.Rows.Count).End(xlUp).Row ' This will error if you have not slected first row so that is a good check
Dim rngIPs As Range
 Set rngIPs = TL.Offset(1, 0).Resize(Lr - 1, 2)
' rngIPs.Copy

wsAllIPs.Activate ' Range E:F is the one we paste to
' Let Lr = wsAllIPs.Range("F" & wsAllIPs.Rows.Count & "").End(xlUp).Row
Dim NxtRw As Long: Let NxtRw = wsAllIPs.Range("F" & wsAllIPs.Rows.Count & "").End(xlUp).Row + 1

 rngIPs.Copy Destination:=wsAllIPs.Range("E" & NxtRw & "")

wsIPs.Activate
End Sub '
' 16/17 July - Thursday 24 July    https://www.excelfox.com/forum/showthread.php/3007-A-Semi-automated-way-to-note-the-IP-addresses-of-things-viewing-us?p=25105&viewfull=1#post25105
Sub SingleIPList()
Dim StTime As Long: Let StTime = Timer
Dim wsIPs As Worksheet, wsReqs As Worksheet, wsAllReqs As Worksheet, wsAllIPs As Worksheet
 Set wsIPs = ThisWorkbook.Worksheets("IPs"): Set wsReqs = ThisWorkbook.Worksheets("Requests"): Set wsAllReqs = ThisWorkbook.Worksheets("AllRequests"): Set wsAllIPs = ThisWorkbook.Worksheets("AllIPs")
Dim Lr As Long
 Let Lr = wsAllIPs.Range("E" & wsAllIPs.Rows.Count & "").End(xlUp).Row

Dim rngIPs As Range
 Set rngIPs = wsAllIPs.Range("E2:F" & Lr & "")

Dim Cnt As Long
    For Cnt = 2 To Lr Step 1
        'If Len(wsAllReqs.Range("E" & Cnt & "").Value2) > 255 Then GoTo NxtCnt
        If wsAllIPs.Range("F" & Cnt & "") = "" Or wsAllIPs.Range("F" & Cnt & "") = Empty Or Cnt = Lr Then GoTo ExtSb  ' This should happen as we are deleting cells so eventually we will reach the end of the shortened range ( It gets shortened every time a row is deleted. )  If we are doung a second take nd nothing happens we will reach  Lr  but the search range becomes that with  Lr  in it which causes a glitch Then goto ExtSb ' This should happen as we are deleting cells so eventually we will reach the end of the shortened range ( It gets shortened every time a row is deleted
    Dim rngFnd As Range, rngSrch As Range
    Set rngSrch = wsAllIPs.Range("F" & Cnt + 1 & ":F" & Lr & "") '  +1  because I dont want to be searching the range including the value I am looking for, or I will find it as last, (after getting to the end and then starting again), and delete the fucker
    Dim Wot As String
    Let Wot = Replace(wsAllIPs.Range("F" & Cnt & "").Value2, vbTab, "", 1, -1, vbBinaryCompare)
    Let Wot = Replace(Wot, vbCr & vbLf, "", 1, -1, vbBinaryCompare)
    Let Wot = Trim(Wot)
'    Set rngFnd = rngSrch.Find(What:=Wot, After:=wsAllIPs.Range("F" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
    Set rngFnd = rngSrch.Find(What:=Wot, After:=wsAllIPs.Range("F" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        Do While Not rngFnd Is Nothing
        Let wsAllIPs.Range("E" & Cnt & "") = wsAllIPs.Range("E" & Cnt & "").Value + rngFnd.Offset(0, -1).Value ' Hits
        'Let wsAllReqs.Range("F" & Cnt & "") = wsAllReqs.Range("F" & Cnt & "").Value & vbCr & vbLf & " " & rngFnd.Offset(0, 1).Value ' IP addresses making the hits/ requests
        'Let wsAllReqs.Range("F" & Cnt & "").WrapText = False
        rngFnd.Offset(0, -1).Resize(1, 2).Delete shift:=xlUp ' Delete duplicate row after adding hits and ip addresses
       
'        Set rngFnd = rngSrch.Find(What:=Wot, After:=wsAllIPs.Range("F" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        Set rngFnd = rngSrch.Find(What:=Wot, After:=wsAllIPs.Range("F" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        Loop ' While Not rngFnd = Nothing
'NxtCnt:
    Next Cnt

ExtSb:
Debug.Print Int((Timer - StTime) / 60) & "min  " & Format(Now, "ddd dd mmm yyyy hh:nn")
End Sub

Sub SortOf()
Dim wsIPs As Worksheet, wsReqs As Worksheet, wsAllReqs As Worksheet, wsAllIPs As Worksheet
 Set wsIPs = ThisWorkbook.Worksheets("IPs"): Set wsReqs = ThisWorkbook.Worksheets("Requests"): Set wsAllReqs = ThisWorkbook.Worksheets("AllRequests"): Set wsAllIPs = ThisWorkbook.Worksheets("AllIPs")
Dim Lr As Long
 Let Lr = wsAllIPs.Range("F" & wsAllReqs.Rows.Count & "").End(xlUp).Row
Dim rngIPs As Range
 Set rngIPs = wsAllIPs.Range("E2:F" & Lr & "")
 rngIPs.Sort Key1:=rngIPs.Columns(1), Order1:=xlDescending
End Sub



---

Later

Improved Requests merging coding

The spreadsheet interaction coding can be preferable in coding development as it is easier to see what is going on and modify. Almost always such coding is slow in comparison with other ways.
In the case of the Requests merging coding, Sub SingleReqList() the time it takes is becoming unacceptable. I am not sure of the exact cause. Possibly the longer strings in the What:= and the deleting of row
Just to refresh the memory of current coding: the coding loops down, and considers in turn each request in the collected lists, then tries to find the same request further down. Then any found duplicate request is deleted ( by deleting the spreadsheet row holding it, across three columns ( Views ; Request ; IPAddressees ) ) by the coding but only after the
_number of views of that the duplicate row
and
_ The IPAddressees
, are added to the row being considered.

Dictionary alternative
How about this:
Loop through each / consider each row, (still keeping for now that bit spreadsheet interaction), and if that request string has not yet been encountered, we .Add the Request string as the Key:= of a dictionary or dictionaries, with the Items:= somehow used for the other information.
If we have encountered the string request, then we modify the items of that key appropriately, (and of course do not add a duplicate key, which is not allowed anyway, and an attempt would error, in the Dictionary)
So then finally in the dictionaries(s) we have the information we want
A bit of Array manipulation of that information is done to paste out the results as we want them, that is to say how we have them so far.
The dictionaries(s) coding remains not optimised at this stage, the idea to keep as easier to see what is going on and modify, the extra efficiency only being added as we must for now.
Performance improvements will be difficult to quantify, as their may be influences on performance, especially on the initial previous codings, from what is already on the spreadsheet.
In fact, in a few posts on, I will probably reorganise my main file, with a few intuitive ideas to tidy the thing up a bit.

I do not want to get too bogged down in speed tests, as I want to move on, but in the next few posts I may at some time try to give some better comparisons. Perhaps I will leave this page 3 for that purpose, and page 4 will try to move on with the main aim of this thread, to get some automated results, or rather a lot of them so as to get some conclusions in other Threads

This was a very quick test using the two codings below, which are the initial dictionaries one and a version similar to that used so far for the Requests merging
I only did a merge on a two day low viewings list, from the period 31 July and 6 August
The dictionary took under a minute, the older original type took about 4 minutes

The file is uploaded, and on this page 3 will be the last use of that main summary file in that form, as I want to tidy it up a bit, before moving on

Code:

---

' 31 July and 6 August Low
Sub SingleReqList()
Dim StTime As Long: Let StTime = Timer
Dim wsIPs As Worksheet, wsReqs As Worksheet, wsAllReqs As Worksheet, wsAllIPs As Worksheet
 Set wsIPs = ThisWorkbook.Worksheets("IPs"): Set wsReqs = ThisWorkbook.Worksheets("Requests"): Set wsAllReqs = ThisWorkbook.Worksheets("AllRequests"): Set wsAllIPs = ThisWorkbook.Worksheets("AllIPs")
Dim Lr As Long
' Let Lr = wsAllReqs.Range("D" & wsAllReqs.Rows.Count & "").End(xlUp).Row
 Let Lr = wsAllReqs.Range("J" & wsAllReqs.Rows.Count & "").End(xlUp).Row

Dim rngReqs As Range
' Set rngReqs = wsAllReqs.Range("D2:F" & Lr & "")
 Set rngReqs = wsAllReqs.Range("J2:L" & Lr & "")

Dim Cnt As Long
    For Cnt = 2 To Lr Step 1
'        If Len(wsAllReqs.Range("E" & Cnt & "").Value2) > 255 Then GoTo NxtCnt
'        If wsAllReqs.Range("E" & Cnt & "") = "" Or wsAllReqs.Range("E" & Cnt & "") = Empty Or Cnt = Lr Then GoTo ExtSb ' This should happen as we are deleting cells so eventually we will reach the end of the shortened range ( It gets shortened every time a row is deleted. )  If we are doung a second take nd nothing happens we will reach  Lr  but the search range becomes that with  Lr  in it which causes a glitch
        If Len(wsAllReqs.Range("K" & Cnt & "").Value2) > 255 Then GoTo NxtCnt
        If wsAllReqs.Range("K" & Cnt & "") = "" Or wsAllReqs.Range("K" & Cnt & "") = Empty Or Cnt = Lr Then GoTo ExtSb ' This should happen as we are deleting cells so eventually we will reach the end of the shortened range ( It gets shortened every time a row is deleted. )  If we are doung a second take nd nothing happens we will reach  Lr  but the search range becomes that with  Lr  in it which causes a glitch
    Dim rngFnd As Range, rngSrch As Range
'    Set rngSrch = wsAllReqs.Range("E" & Cnt + 1 & ":E" & Lr & "") ' I dont want to be searching the range including the value i am looking for, or I will find it as last, (after getting to the end and then starting again), and delete the fucker
'    Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("E" & Cnt & "").Value2, After:=wsAllReqs.Range("E" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
    Set rngSrch = wsAllReqs.Range("K" & Cnt + 1 & ":K" & Lr & "") ' I dont want to be searching the range including the value i am looking for, or I will find it as last, (after getting to the end and then starting again), and delete the fucker
    Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("K" & Cnt & "").Value2, After:=wsAllReqs.Range("K" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
      '    Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("E" & Cnt & "").Value2, After:=wsAllReqs.Range("E" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        Do While Not rngFnd Is Nothing
'        Let wsAllReqs.Range("D" & Cnt & "") = wsAllReqs.Range("D" & Cnt & "").Value + rngFnd.Offset(0, -1).Value ' Hits
'        Let wsAllReqs.Range("F" & Cnt & "") = wsAllReqs.Range("F" & Cnt & "").Value & vbCr & vbLf & " " & rngFnd.Offset(0, 1).Value ' IP addresses making the hits/ requests
'        Let wsAllReqs.Range("F" & Cnt & "").WrapText = False
        Let wsAllReqs.Range("J" & Cnt & "") = wsAllReqs.Range("J" & Cnt & "").Value + rngFnd.Offset(0, -1).Value ' Hits
        Let wsAllReqs.Range("L" & Cnt & "") = wsAllReqs.Range("L" & Cnt & "").Value & vbCr & vbLf & " " & rngFnd.Offset(0, 1).Value ' IP addresses making the hits/ requests
        Let wsAllReqs.Range("L" & Cnt & "").WrapText = False
        rngFnd.Offset(0, -1).Resize(1, 3).Delete Shift:=xlUp ' Delete duplicate row after adding hits and ip addresses
       
'        Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("E" & Cnt & "").Value2, After:=wsAllReqs.Range("E" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("K" & Cnt & "").Value2, After:=wsAllReqs.Range("K" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlWhole, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
      '        Set rngFnd = rngSrch.Find(What:=wsAllReqs.Range("E" & Cnt & "").Value2, After:=wsAllReqs.Range("E" & Cnt + 1 & ""), LookIn:=xlValues, Lookat:=xlPart, Searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
        Loop ' While Not rngFnd = Nothing
NxtCnt:
    Debug.Print Cnt
    Next Cnt

ExtSb:
Debug.Print Int((Timer - StTime) / 60) & "min  " & Format(Now, "ddd dd mmm yyyy hh:nn")
End Sub ' 4min  Do 25 Sep 2025 22:29
Sub SingleReqListDics()
Dim StTime As Long: Let StTime = Timer
Dim wsIPs As Worksheet, wsReqs As Worksheet, wsAllReqs As Worksheet, wsAllIPs As Worksheet
 Set wsIPs = ThisWorkbook.Worksheets("IPs"): Set wsReqs = ThisWorkbook.Worksheets("Requests"): Set wsAllReqs = ThisWorkbook.Worksheets("AllRequests"): Set wsAllIPs = ThisWorkbook.Worksheets("AllIPs")
Dim Lr As Long
' Let Lr = wsAllReqs.Range("D" & wsAllReqs.Rows.Count & "").End(xlUp).Row
 Let Lr = wsAllReqs.Range("J" & wsAllReqs.Rows.Count & "").End(xlUp).Row

Dim rngReqs As Range
' Set rngReqs = wsAllReqs.Range("D2:F" & Lr & "")
 Set rngReqs = wsAllReqs.Range("J2:L" & Lr & "")
Dim DicVw As Object, DicIP As Object
 Set DicVw = CreateObject("Scripting.Dictionary"): Set DicIP = CreateObject("Scripting.Dictionary")
Dim Cnt As Long
Rem Make Dics Item or adds to it
    For Cnt = 2 To Lr Step 1
        If Not DicVw.exists(wsAllReqs.Range("K" & Cnt & "").Value) Then
        DicVw.Add Key:=wsAllReqs.Range("K" & Cnt & "").Value, Item:=wsAllReqs.Range("J" & Cnt & "").Value
        DicIP.Add Key:=wsAllReqs.Range("K" & Cnt & "").Value, Item:=wsAllReqs.Range("L" & Cnt & "").Value
        Else ' Add the infomation of view count and IPAddresses
        Let DicVw(wsAllReqs.Range("K" & Cnt & "").Value) = DicVw(wsAllReqs.Range("K" & Cnt & "").Value) + wsAllReqs.Range("J" & Cnt & "").Value
        Let DicIP(wsAllReqs.Range("K" & Cnt & "").Value) = DicIP(wsAllReqs.Range("K" & Cnt & "").Value) & vbCr & vbLf & " " & wsAllReqs.Range("L" & Cnt & "").Value
        End If
NxtCnt:
    'Debug.Print Cnt
    Next Cnt
Rem output
Dim arrReqVw() As Variant, arrVw() As Variant, arrIP() As Variant, arrReqIP() As Variant
 Let arrReqVw() = DicVw.keys(): arrVw() = DicVw.items(): arrIP() = DicIP.items(): arrReqIP() = DicIP.keys()

 Let wsAllReqs.Range("N2").Resize(UBound(arrReqVw()) + 1, 1) = Application.Transpose(arrReqVw())
 'Let wsAllReqs.Range("P2").Resize(UBound(arrReqVw()) + 1, 1) = Application.Transpose(arrReqVw())
 Let wsAllReqs.Range("M2").Resize(UBound(arrVw()) + 1, 1) = Application.Transpose(arrVw())
 Let wsAllReqs.Range("M2").Resize(UBound(arrVw()) + 1, 1) = Application.Index(arrVw(), 1, Evaluate("Row(1:" & UBound(arrVw()) + 1 & ")"))
Dim strIPs As String, arrIPsstr() As String ' Problem with string longer than 255 characters in a Transpose (or Index) when variant arrays have any element with a string over 255 characters
 Let strIPs = Join(arrIP(), "|")  '  https://stackoverflow.com/questions/35395789/excel-vba-need-workaround-for-255-transpose-character-limit-when-returning-vari/79775234#79775234
 Let arrIPsstr() = Split(strIPs, "|") ' https://stackoverflow.com/a/79775234/4031841
 Let wsAllReqs.Range("O2").Resize(UBound(arrIPsstr()) + 1, 1) = Application.Index(arrIPsstr(), 1, Evaluate("Row(1:" & UBound(arrIPsstr()) + 1 & ")"))
 Let wsAllReqs.Cells.WrapText = False
ExtSb:
Debug.Print Int((Timer - StTime) / 60) & "min  " & Format(Now, "ddd dd mmm yyyy hh:nn")
End Sub ' 0min  Do 25 Sep 2025 22:19

---

---

Share ‘SummaryRequestsIPs_23 Sept 2025 Speed Test.xlsm’ https://app.box.com/s/9p9ls9ob6jh9rl9u16lrrzl3vcqzej03
Share ‘SummaryRequestsIPs_23 Sept 2025 Speed Test.zip’ https://app.box.com/s/0y1916jdasek1pcxi6kuzaq1mg8mvh8b

https://stackoverflow.com/questions/...75234#79775234
https://stackoverflow.com/a/79775234/4031841 me
https://stackoverflow.com/questions/...60376_35399740

Spare post #28

Spare post #29

Spare post #30