Code:
Sub RequestsOrdering() ' You need something like SummaryRequestsIPsDailys.xlsm open
Dim WsReq As Worksheet, WsIP As Worksheet, WsReqErr As Worksheet ' , WsSts As Worksheet
Set WsReq = ThisWorkbook.Worksheets("Requests"): Set WsIP = ThisWorkbook.Worksheets("IPAddresses"): Set WsReqErr = ThisWorkbook.Worksheets("UnkownLocations")
Dim LrReq As Long, LrIP As Long, LrReqErr As Long
Let LrReq = WsReq.Range("B" & WsReq.Rows.Count & "").End(xlUp).Row: LrIP = WsIP.Range("B" & WsIP.Rows.Count & "").End(xlUp).Row: Let LrReqErr = WsReqErr.Range("B" & WsReqErr.Rows.Count & "").End(xlUp).Row
Let WsReq.Range("A1") = WsReq.Range("A1").Value & " " & ThisWorkbook.Name
WsReq.Activate
Let WsReq.Range("A1") = Replace(ThisWorkbook.Name, ".xls", "", 1, -1, vbBinaryCompare)
Let WsReq.Range("A1") = Replace(WsReq.Range("A1").Value, "IPAddressesWatchingExcelFox_Refresh", "", 1, -1, vbBinaryCompare)
Let WsReq.Range("B1:C1") = "" ' I don't want this info messing up the little space I have for title info, it is legacy here to remind me of somethhing, not sure what
Dim rngReq As Range ' The three column range
Set rngReq = WsReq.Range("A2:C" & LrReq & "")
Let rngReq.WrapText = False ' all request lines same small/ normal height height
Let WsReq.Range("A" & LrReq + 1 & "") = "=sum(A2:A" & LrReq & ")"
rngReq.Sort Key1:=WsReq.Range("A2:A" & LrReq & ""), Order1:=xlDescending
rngReq.Offset(-1, 0).Resize(rngReq.Rows.Count + 1, rngReq.Columns.Count).Copy
Application.Wait Time:=Now + TimeValue("00:00:04")
Dim Ws As Worksheet: Set Ws = Workbooks("SummaryRequestsIPsDailys.xlsm").Worksheets("Requests")
Ws.Activate
Application.Wait Time:=Now + TimeValue("00:00:01")
Dim NxtClm As Long: Let NxtClm = Ws.Cells.Item(1, Ws.Columns.Count).End(xlToLeft).Column
Ws.Cells.Item(1, NxtClm + 3).Select
End Sub
' C:\Users\Elston\AppData\Roaming\Microsoft\Windows\Network Shortcuts
' showthread.php?t=2993/Alan and Clare Testing
Sub IPsSaniierung() ' To tidy up after coding
Rem 0 worksheets info
Dim WsReq As Worksheet, WsIP As Worksheet, WsReqErr As Worksheet, WsSts As Worksheet
Set WsReq = ThisWorkbook.Worksheets("Requests"): Set WsIP = ThisWorkbook.Worksheets("IPAddresses"): Set WsReqErr = ThisWorkbook.Worksheets("UnkownLocations"): Set WsSts = ThisWorkbook.Worksheets("Stats")
WsSts.Cells.ClearContents
Dim LrReq As Long, LrIP As Long, LrReqErr As Long, LrSts As Long
Let LrReq = WsReq.Range("B" & WsReq.Rows.Count & "").End(xlUp).Row: LrIP = WsIP.Range("B" & WsIP.Rows.Count & "").End(xlUp).Row: Let LrReqErr = WsReqErr.Range("B" & WsReqErr.Rows.Count & "").End(xlUp).Row
Dim LcSts As Long, NxtClm As Long
Let LcSts = WsSts.Cells.Item(1, WsSts.Columns.Count).End(xlToLeft).Column
Let NxtClm = LcSts + 1
WsSts.Activate
Let WsSts.Range("A1").Offset(0, NxtClm - 1) = Replace(ThisWorkbook.Name, ".xls", "", 1, -1, vbBinaryCompare) ' But iof legacy to when I might have had more / previous columns ion this worksheet
Let WsSts.Range("A1").Offset(0, NxtClm - 1) = Replace(WsSts.Range("A1").Offset(0, NxtClm - 1), "IPAddressesWatchingExcelFox_Refresh", "", 1, -1, vbBinaryCompare) ' But iof legacy to when I might have had more / previous columns ion this worksheet
Dim rngIPs As Range
Set rngIPs = WsIP.Range("A2:B" & LrIP & "")
rngIPs.Copy Destination:=WsSts.Range("A2").Offset(0, NxtClm - 1)
Set rngIPs = WsSts.Range("A2").Offset(0, NxtClm - 1).Resize(rngIPs.Rows.Count, rngIPs.Columns.Count)
Let LrSts = LrIP
' Rem Tidy up duplicate IP entries, based on assuming the order has been done on IPs in Sub GetRefreshesIPAddressWatchingThingsAtExcelFox()
Dim Cnt As Long
For Cnt = LrSts To 2 Step -1
Dim strIP1 As String, strIP2 As String
Let strIP1 = WsSts.Range("C" & Cnt & "").Value2: strIP2 = WsSts.Range("C" & Cnt + 1 & "").Value2
' Debug.Print
' Debug.Print Len(strIP1)
Let strIP1 = Replace(strIP1, vbTab, "", 1, -1, vbBinaryCompare) ': Debug.Print Len(strIP1)
Let strIP1 = Replace(strIP1, vbCr & vbLf, "", 1, -1, vbBinaryCompare) ': Debug.Print Len(strIP1)
Let strIP1 = Trim(strIP1) ': Debug.Print Len(strIP1)
' Debug.Print
' Debug.Print Len(strIP2)
Let strIP2 = Replace(strIP2, vbTab, "", 1, -1, vbBinaryCompare) ': Debug.Print Len(strIP2)
Let strIP2 = Replace(strIP2, vbCr & vbLf, "", 1, -1, vbBinaryCompare) ': Debug.Print Len(strIP2)
Let strIP2 = Trim(strIP2) ': Debug.Print Len(strIP2)
' Debug.Print
If strIP1 = strIP2 Then
Let WsSts.Range("B" & Cnt & "") = WsSts.Range("B" & Cnt & "").Value2 + WsSts.Range("B" & Cnt + 1 & "").Value2
Let WsSts.Range("C" & Cnt & "") = strIP1 ' The sanitised value
WsSts.Range("B" & Cnt + 1 & ":C" & Cnt + 1 & "").Delete Shift:=xlUp ' W deleted what was behiud/above us
Else
End If
Next Cnt
Rem We lost some rows now, so the last row has changed
Let LrSts = WsSts.Range("B" & WsSts.Rows.Count & "").End(xlUp).Row
Rem re-order
Set rngIPs = WsSts.Range("B2:C" & LrSts & "")
rngIPs.Sort Key1:=rngIPs.Columns(1), Order1:=xlDescending
Rem
' Let WsSts.Range("B" & LrSts + 1 & "") = "=SUM(B2:B" & LrSts & ")"
Let WsSts.Range("B" & LrSts + 1 & "") = WsSts.Evaluate("SUM(B2:B" & LrSts & ")")
Rem get ready to paste in summary file
rngIPs.Offset(-1, 0).Resize(rngIPs.Rows.Count + 2, rngIPs.Columns.Count).Copy
Application.Wait Time:=Now + TimeValue("00:00:04")
Dim Ws As Worksheet: Set Ws = Workbooks("SummaryRequestsIPsDailys.xlsm").Worksheets("IPs")
Ws.Activate
Application.Wait Time:=Now + TimeValue("00:00:01")
Let NxtClm = Ws.Cells.Item(1, Ws.Columns.Count).End(xlToLeft).Column
Ws.Cells.Item(1, NxtClm + 2).Select
End Sub
Sub UnknownLocationsTotheSummaryFile()
Dim DailyWb As Workbook, DailyWs As Worksheet
Set DailyWb = Me.Parent
Set DailyWs = DailyWb.Worksheets("UnkownLocations")
DailyWs.Activate
Dim DlyLr As Long: Let DlyLr = DailyWs.Range("B" & DailyWs.Rows.Count & "").End(xlUp).Row '
Dim rngDly As Range
Set rngDly = DailyWs.Range("A2:C" & DlyLr & "")
rngDly.Sort Key1:=DailyWs.Range("A2:A" & DlyLr & ""), Order1:=xlDescending
If DlyLr > 1 Then
rngDly.Copy
Else
Let DailyWs.Range("A1") = DailyWs.Range("A1").Value ' A quick trick to change something so that the last change date changes in file explorer
End If
' rngDly.Offset(50, 0).Select ' To check to see if this effectively scroll
Dim WsS As Worksheet: Set WsS = Workbooks("SummaryRequestsIPsDailys.xlsm").Worksheets("UnknownLocations")
WsS.Activate
Dim Nr As Long
Let Nr = WsS.Range("A" & WsS.Rows.Count & "").End(xlUp).Row + 1 ' WsS.Range("B" & WsS.Rows.Count & "").End(xlUp).Row + 1 Bis an option to overwite the column A of the day before
Let WsS.Range("A" & Nr & "") = Replace(Replace(DailyWs.Parent.Name, "IPAddressesWatchingExcelFox_", ""), ".xls", "")
' WsS.Range("A" & Nr & "").Offset(13, 0).Select
If DlyLr > 1 Then
WsS.Paste Destination:=WsS.Range("A" & Nr + 1 & "")
Else
End If
' Call ReCheckDuplicates
Let WsS.Cells.WrapText = False
' Now select the data rows just been put in, to make it easier if there is a lot to select ##
WsS.Activate: WsS.Range("A" & Nr & "").Select
Application.Wait Time:=Now + TimeValue("00:00:01")
Dim Lr As Long: Let Lr = WsS.Range("A" & WsS.Rows.Count & "").End(xlUp).Row
If Nr = Lr Then
' Nothing was pasted in so nothing to select
Else
WsS.Range("A" & Nr + 1 & ":A" & Lr & "").Select
End If
' ActiveCell.Offset(30, 0).Select ' Trick to get things in focus but that fucks up the ## select the data rows just been put in, to make it easier if there is a lot to select
DailyWs.Parent.Close savechanges:=True
End Sub
Reply With Quote
Bookmarks