Получение ошибки при запуске кода ниже. Это сработало в прошлом месяце, похоже, перестало работать, так как я выполнил обновление данных Octobers.
Сценарий должен получать данные из Derek_Calc, который представляет собой список всех входов в систему на ежедневной основе для приложения на сервере. Затем эти данные сжимаются, чтобы указать, сколько людей заходят в час в любой день.
Следующая строка используется для установки информации о дате добавления данных в таблицу и датах проверки в DEREK_Calcs:
Set tempRange = target1.Range("B1706:B1736")
Sub PopulateConcurrency() 'for re-populating specific dates for the 'DEREK_Concurrency_Logins' sheet
'UPDATE THE DATE RANGE below!
Dim thisBook As Workbook
Dim target1 As Worksheet
Dim target2 As Worksheet
Dim dbSheetNames(1 To 2) As String
Dim cell As Variant
Dim cell2 As Variant
Dim searchDate As String
Dim firstColDate As Boolean
Dim userIdLoginCount As Long
Dim startHour As String
Dim endHour As String
Dim startDateTime As Date
Dim endDateTime As Date
Dim startDateHour As Date
Dim endDateHour As Date
Dim hourCounter As Integer
Dim startRange As Range
Dim endRange As Range
Dim tempString As String
Dim counter As Long
Dim userIds() As Long
Dim uniqueIds As Collection, c
Dim targCellRange As Range
Dim tempRange As Range
Dim tempRange2 As Range
dbSheetNames(1) = "DEREK_Concurrency_Logins"
dbSheetNames(2) = "DEREK_Calcs"
Set thisBook = ThisWorkbook
Set target1 = thisBook.Sheets(dbSheetNames(1))
Set target2 = thisBook.Sheets(dbSheetNames(2))
'prepare variables
userIdLoginCount = 0
hourCounter = 0
'de-activate re-calculations for this sheet as these will be updated later
target1.EnableCalculation = False
target2.EnableCalculation = False
'stop screen refreshing
Application.ScreenUpdating = False
Set tempRange = target1.Range("B1706:B1736") 'UPDATE THE DATE RANGE FROM COLUMN B Of THE 'DEREK_Concurrency_Logins' sheet
For Each cell In tempRange 'loop through each date in the DEREK_Concurrency_User_Logins sheet
searchDate = cell.Value
searchDate = Format(searchDate, "dd/mm/yyyy")
firstColDate = True
hourCounter = 0
For hourCounter = 0 To 16 'loop to next hour time range
'get start hour and end hour
startHour = target1.Cells(2, (3 + hourCounter))
startHour = Format(startHour, "hh:mm")
endHour = target1.Cells(2, (4 + hourCounter))
endHour = Format(endHour, "hh:mm")
'prepare variables
Erase userIds
Set uniqueIds = Nothing
Set uniqueIds = New Collection
userIdLoginCount = 0
counter = 0
With target2
Set tempRange2 = target2.Range("DEREK_LoginDaily")
For Each cell2 In tempRange2 'loop through each cell2 In DEREK_LoginDaily
If (StrComp(searchDate, cell2.Value) = 0) Then 'check for date match
If firstColDate = False Then
Set startRange = cell2
Set endRange = cell2
'get start and end hours for the hour period
startDateTime = startRange.Offset(0, 7).Value
endDateTime = endRange.Offset(0, 8).Value
'get the login start and finish times
tempString = Day(startDateTime) & "/" & Month(startDateTime) & "/" & Year(startDateTime) & " " & Format(startHour, "hh:mm")
startDateHour = CDate(tempString)
tempString = Day(endDateTime) & "/" & Month(endDateTime) & "/" & Year(endDateTime) & " " & Format(endHour, "hh:mm")
endDateHour = CDate(tempString)
If startDateTime <= startDateHour And endDateTime >= endDateHour Then
Sheets(dbSheetNames(2)).Select
startRange.Offset(0, 10).Select
startRange.Offset(0, 10).Activate
ReDim Preserve userIds(counter)
If (startRange.Offset(0, 10).Length > 0) Then
If startRange.Offset(0, 6).Value = 1 Then
userIds(counter) = startRange.Offset(0, 10).Value
End If
End If
counter = counter + 1 'increment counter
End If 'end hour concurency check
Else 'if firstColDate is True
startHour = target1.Cells(2, 2) 'code for 7am - 8am, set startHour to 07:00
endHour = target1.Cells(2, 4) 'set endHour to 08:00
Set startRange = cell2
Set endRange = cell2
'get start and end hours for the hour period
startDateTime = startRange.Offset(0, 7).Value
endDateTime = endRange.Offset(0, 8).Value
'get the login start and finish times
tempString = Day(startDateTime) & "/" & Month(startDateTime) & "/" & Year(startDateTime) & " " & Format(startHour, "hh:mm")
startDateHour = CDate(tempString)
tempString = Day(endDateTime) & "/" & Month(endDateTime) & "/" & Year(endDateTime) & " " & Format(endHour, "hh:mm")
endDateHour = CDate(tempString)
If startDateTime <= startDateHour And endDateTime >= endDateHour Then
Sheets(dbSheetNames(2)).Select
'THIS IS WHERE THE ERROR IS :-(
startRange.Offset(0, 10).Select
startRange.Offset(0, 10).Activate
ReDim Preserve userIds(counter)
If (startRange.Offset(0, 10).Length > 0) Then
If startRange.Offset(0, 6).Value = 1 Then
userIds(counter) = startRange.Offset(0, 10).Value
End If
End If
counter = counter + 1 'increment counter
End If 'end hour concurency check
End If 'end if firstColDate
End If 'end if a date match
Next cell2 'loop through each cell2 In DEREK_LoginDaily
End With
'get unique values by putting array into a collection
On Error Resume Next
For Each c In userIds
If Not IsEmpty(c) Then
uniqueIds.Add Item:=c, Key:=CStr(c)
End If
Next c
'populate target cell
Set targCellRange = cell
targCellRange.Offset(0, (2 + hourCounter)) = (uniqueIds.count)
firstColDate = False
Next hourCounter 'loop to next hour time range
firstColDate = True
Next cell 'loop through each date in the DEREK_Concurrency_User_Logins sheet
MsgBox "Complete"
End Sub