Vba宏來彙總每個日期在colymn的數據

Question

即時通訊新的vba，這是我的第二個問題在這裏 我有一個日期爲 01-june-16的專欄。 Cashier1。 100. 36 01-june-16。 Cashier2。 300. 58 02-juns-16。 Cashier1。 500. 36 02-jun-16。 Cashiet1。 65. 02六月-16。 Cashier2。 100. 54

我需要爲每個日期的相應行中的每個收銀員添加數據，所以在6月第一天，我應該有（136 + 358）那一天的交易。

不知道我的意見將如何，因此任何幫助或建議將不勝感激。感謝提前我道歉的智能手機發布im可讀性。但每個日期是一個新的列

Answer 1

試試這個代碼讓我知道它是否工作。

Sub RunSubtotal() 
Dim WS As Worksheet 
Dim MaxRow As Long, I As Long 
Dim Tot As Double 
Dim Dte As String 

Set WS = ActiveSheet 
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row 
Tot = 0 

'---> Clear Col C 
WS.Range("C:C").ClearContents 

'---> Sort Worksheet by Date 
WS.UsedRange.Sort key1:=WS.Range("A1"), order1:=xlAscending, Header:=xlYes 
Dte = WS.Cells(1, "A") 

'---> Start Process 
For I = 1 To MaxRow + 1 
If WS.Range("A" & I) <> Dte Then 
    WS.Cells(I - 1, "C") = Tot 
    Dte = WS.Cells(I, "A") 
    Tot = 0 
End If 

Tot = Tot + Val(WS.Cells(I, "B")) 

Next I 

MsgBox ("Totals inserted in Col C by date successfully.") 

End Sub 

Answer 2

我建議使用SUMIF式兩種溶液，避免了使用For...Next，一次設置需要的值。兩者都提供選擇保留公式或公式返回的值。

假設：

• 數據開始在B2
• 數據具有以下標題：日期，出納，金額
• 添加頁眉：Total.Daily以顯示所需的結果
• 第二溶液假設結果摘要開始於G2:G3

級前申請的解決方案

1.-在數據範圍彙總

Sub Adding_Amount_by_Date() 
Const kFmlTotDay As String = "=SUMIF(#rDate,#Date,#rAmount)"   'SUMIF formula to apply 
Dim rDta As Range 
Dim sFml As String 
Dim rTmp As Range, sFld As String, bPos As Byte 

    Rem Set Data Range 
    Set rDta = ThisWorkbook.Sheets("DATA").Range("B2").CurrentRegion 'Update as required 

    Rem Working With Body Range (Data Range excluding Headers) 
    With rDta.Offset(1).Resize(-1 + rDta.Rows.Count) 

     Rem Reset Formula 
     sFml = kFmlTotDay 

     Rem Amount Range 
     sFld = "Amount"             'Update as required 
     bPos = WorksheetFunction.Match(sFld, rDta.Rows(1), 0) 
     Set rTmp = .Columns(bPos) 
     sFml = Replace(sFml, "#r" & sFld, rTmp.Address) 

     Rem Date Range 
     sFld = "Date"             'Update as required 
     bPos = WorksheetFunction.Match(sFld, rDta.Rows(1), 0) 
     Set rTmp = .Columns(bPos) 
     sFml = Replace(sFml, "#r" & sFld, rTmp.Address) 
     sFml = Replace(sFml, "#" & sFld, rTmp.Cells(1).Address(0, 1)) 

     Rem Enter Daily Total (Formula or Value) 
     sFld = "Total.Daily"           'Update as required 
     bPos = WorksheetFunction.Match(sFld, rDta.Rows(1), 0) 
     .Columns(bPos).Formula = sFml         'Enter formula 
     .Columns(bPos).Value = .Columns(bPos).Value2     'Replace formula with values (comment this line to have keep the formulas) 

    End With 

End Sub 

2：在彙總範圍

Sub Adding_Amount_by_Date_OutputRange() 
Const kFmlTotDay As String = "=SUMIF(#rDate,#Date,#rAmount)"   'SUMIF formula to apply 
Dim rOut As Range 
Dim rDta As Range 
Dim sFml As String 
Dim rTmp As Range, sFld As String, bPos As Byte 

    Rem Reset Output Table Range 
    Set rOut = ThisWorkbook.Sheets("DATA").Range("G2").CurrentRegion 'Update as required 
    With rOut 
     If .Rows.Count > 1 Then 
      .Offset(1).Resize(-1 + rOut.Rows.Count).ClearContents 
     Set rOut = rOut.Cells(1).CurrentRegion 
    End If 
    End With 

    Rem Set Data Range 
    Set rDta = ThisWorkbook.Sheets("DATA").Range("B2").CurrentRegion 'Update as required 

    Rem Work With Data Range Body (excluding Headers) 
    With rDta.Offset(1).Resize(-1 + rDta.Rows.Count) 

     Rem Reset Formula 
     sFml = kFmlTotDay 

     Rem Amount Range 
     sFld = "Amount"             'Update as required 
     bPos = WorksheetFunction.Match(sFld, rDta.Rows(1), 0) 
     Set rTmp = .Columns(bPos) 
     sFml = Replace(sFml, "#r" & sFld, rTmp.Address) 

     Rem Date Range 
     sFld = "Date"             'Update as required 
     bPos = WorksheetFunction.Match(sFld, rDta.Rows(1), 0) 
     Set rTmp = .Columns(bPos) 
     sFml = Replace(sFml, "#r" & sFld, rTmp.Address) 
     sFml = Replace(sFml, "#" & sFld, rOut.Cells(2, 1).Address(0, 1)) 

    End With 

    Rem List Unique Date in Output Range 
    With rOut 
     rDta.Columns(bPos).AdvancedFilter _ 
      Action:=xlFilterCopy, _ 
      CriteriaRange:=rDta.Columns(bPos), _ 
      CopyToRange:=.Cells(1), _ 
      Unique:=True 
     .Worksheet.Names("Criteria").Delete 
     .Worksheet.Names("Extract").Delete 
    End With 

    Rem Enter Daily Total (Formula or Value) 
    Set rOut = rOut.Cells(1).CurrentRegion 
    With rOut.Offset(1).Resize(-1 + rOut.Rows.Count).Columns(2) 
     .Formula = sFml             'Enter formula 
     .Value = .Columns(bPos).Value2         'Replace formula with values (comment this line to have keep the formulas) 
    End With 

    End Sub 

共申請這兩種解決方案

後

推薦閱讀以下網頁獲得的資源有了更深的瞭解使用：

Excel functions (by category)，Excel Objects，Range Object (Excel)，Range.Offset Property (Excel)，

Variables & Constants，WorksheetFunction Object (Excel)，With Statement