依所劃分的時間抓資料加總

imzues

請問一下有辦法用巨集
把不同時間的資料，但依時間的區格把他分別匯出加總嗎??
麻煩解答 謝謝

oobird

1. Sub yy()
   
2. Dim arr(1 To 6, 0), rng, i%, h%
   
3. rng = [c5:d12]
   
4. For i = 1 To UBound(rng)
   
5. h = Application.Match(Hour(rng(i, 1)), Array(0, 4, 8, 12, 16, 20))
   
6. If h > 0 Then
   
7. arr(h, 0) = arr(h, 0) + rng(i, 2)
   
8. End If
   
9. Next
   
10. [g5].Resize(6, 1) = arr
    
11. End Sub

複製代碼

imzues

請問一下若是我匯出的欄位不是連續的，可能是g5 0000-0400
                                                               g7 0400-0800
像這樣我要在哪邊更改匯出的位置
在麻煩解答 謝謝

GBKEE

回復 3# imzues

1. Sub Ex()
   
2.     Dim E As Range, R As Range, i As Integer, A As Variant, Timer As Date
   
3.     For Each E In [F5:F10]
   
4.         A = Split(E, "-")
   
5.         i = 0
   
6.         For Each R In [C5:C12]
   
7.             Timer = TimeSerial(Hour(R), Minute(R), 0)
   
8.             If Timer >= TimeValue(Format(A(0), "00:00")) Then
   
9.                 If Timer <= TimeValue(Format(A(1), "00:00")) Then
   
10.                     i = i + R.Cells(1, 2)
    
11.                 End If
    
12.             End If
    
13.          Next
    
14.          E.Cells(1, 2) = i
    
15.     Next
    
16. End Sub

複製代碼

imzues

不好意思我可能講得不太清楚，若是我原本是G5那格是0000-0400
                                                            G6那個是0400-0800
但我現在想要每空一格貼資料的話，例如：G5那格是0000-0400
                                                         G7那個是0400-0800
有辦法做到嗎？因為我不太會改
再麻煩解答感謝

GBKEE

回復 5# imzues
附上檔案 說明會清楚些

Hsieh

回復 5# imzues

1. Sub nn()
   
2. Dim A As Range, t#
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. For i = 0 To 20 Step 4
   
5.    mystr = Format(i / 24, "hhmm") & "-" & IIf(i = 20, 2400, Format((i + 4) / 24, "hhmm"))
   
6.    d(mystr) = i / 24
   
7. Next
   
8. kys = d.keys: ar = d.items
   
9. d.RemoveAll
   
10. For Each A In Range([C5], [C65536].End(xlUp))
    
11.    t = TimeValue(Format(A, "hh:mm"))
    
12.    ky = kys(Application.Match(t, ar) - 1)
    
13.    d(ky) = d(ky) + A.Offset(, 1)
    
14. Next
    
15. For Each A In Range([F5], [F65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
    
16.    A.Offset(, 1) = d(A.Value)
    
17. Next
    
18. End Sub

複製代碼

imzues

就像檔案的那種格式 在幫忙解答 謝謝

oobird

Dim arr(1 To 11, 0), rng, i%, h%

rng = [c5:d12]

For i = 1 To UBound(rng)

h = Application.Match(Hour(rng(i, 1)), Array(0, 4, 8, 12, 16, 20))

If h > 0 Then

arr(h * 2 - 1, 0) = arr(h * 2 - 1, 0) + rng(i, 2)

End If

Next

[g5].Resize(11, 1) = arr

imzues

感謝各位大大的解答!!!