[已解决]求高手帮忙解决，统计那个时段上网人数最多

梦想有多远

求高手帮忙解决，统计在哪一个小时内上网的人数最多，如果一个人从五点上到八点，那么5、6、7都算上网，超过8点的话，8点也要算在内

最佳答案

月排行榜 / 总排行榜

wanao2008

2015-12-21 21:00

Sub tJi()
    Dim sj(23)
    For x = 2 To Cells(Rows.Count, "d").End(xlUp).Row
        h1 = Hour(Cells(x, 4))
        h2 = Hour(Cells(x, 5))
        If h2 < h1 Then h2 = h2 + 24
        For y = h1 To h2
            If y >= 24 Then
                sj(y - 24) = sj(y - 24) + 1
            Else
                sj(y) = sj(y) + 1
            End If
        Next
    Next
    [p1:p24] = Application.WorksheetFunction.Transpose(sj)
End Sub
非内存运算，速度会慢一点，写的不太规范（主要是变量没定义）

跳转到最佳答案楼层

QCW911

有偿编写
如需加QQ57726980

grf1973

1. Sub grf()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = [a1].CurrentRegion
   
4.     ReDim brr(0 To 23, 1 To 1)
   
5.     For i = 2 To UBound(arr)
   
6.         If Len(arr(i, 4)) And Len(arr(i, 5)) Then
   
7.             qs = Hour(arr(i, 4)): js = Hour(arr(i, 5))  '起始时间，结束时间
   
8.             For k = qs To js
   
9.                 brr(k, 1) = brr(k, 1) + 1
   
10.             Next
    
11.         End If
    
12.     Next
    
13.     [q:r].Clear
    
14.     [q1] = "时间": [r1] = "人数"
    
15.     [r2].Resize(24) = brr     '各小时人数
    
16.     [q2].Resize(24).Formula = "=row(r[-1]c)-1"     '标注小时数
    
17. End Sub
    

复制代码

lichuanboy44

也试了一下，看是否你需要的。
如果时间没跨天，则此题好解决，如从上午9点至24点，但此题有个例外情况必须考虑，即从晚上18点到次日2点，如果只单纯考虑起始小时数的话，则出错。因for 18 to 2，不进入循环体内部，则此人上网的所有时数均漏统计了。

Sub tt()
  Dim arr(0 To 23), ar3
  Set wk = Worksheets(1)
  n = wk.Range("D65536").End(3).Row
  ReDim ar3(1 To n - 1)
  ar1 = wk.Range("D2:D" & n): ar2 = wk.Range("E2:E" & n)
  For i = 1 To n - 1
     s1 = Year(ar1(i, 1)): s2 = Month(ar1(i, 1)): s3 = Day(ar1(i, 1)): s4 = Hour(ar1(i, 1))
     t1 = CDate(s1 & "/" & s2 & "/" & s3)
     t2 = DateAdd("h", s4, t1)
     t3 = ar2(i, 1)
     时数 = DateDiff("h", t2, t3)
     ar3(i) = 时数 + 1
     p = s4
     For j = 1 To 时数 + 1
        arr(p) = arr(p) + 1
        If p = 23 Then
          p = 0
        Else
          p = p + 1
        End If
     Next
  Next
   wk.[T2:T25].ClearContents
   wk.Range("T2").Resize(24, 1) = WorksheetFunction.Transpose(arr)
End Sub

wanao2008

Sub tJi()
    Dim sj(23)
    For x = 2 To Cells(Rows.Count, "d").End(xlUp).Row
        h1 = Hour(Cells(x, 4))
        h2 = Hour(Cells(x, 5))
        If h2 < h1 Then h2 = h2 + 24
        For y = h1 To h2
            If y >= 24 Then
                sj(y - 24) = sj(y - 24) + 1
            Else
                sj(y) = sj(y) + 1
            End If
        Next
    Next
    [p1:p24] = Application.WorksheetFunction.Transpose(sj)
End Sub
非内存运算，速度会慢一点，写的不太规范（主要是变量没定义）

梦想有多远

grf1973 发表于 2015-12-21 15:49

谢谢老师的解答

梦想有多远

lichuanboy44 发表于 2015-12-21 17:23
也试了一下，看是否你需要的。
如果时间没跨天，则此题好解决，如从上午9点至24点，但此题有个例外情况必须 ...

谢谢老师的解答

梦想有多远

wanao2008 发表于 2015-12-21 21:00
Sub tJi()
    Dim sj(23)
    For x = 2 To Cells(Rows.Count, "d").End(xlUp).Row

谢谢老师的解答