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