Monthify

Question

我有一个日期清单，其中包含每日销售额。我想从这些日期中提取唯一的月份，以便准备月度销售报告。

   Date      Sales
--------------------
07-09-2018   $3,000 
08-09-2018   $2,500 
09-10-2018   $2,800 
10-10-2018   $2,700 
11-11-2018   $2,500 
12-12-2018   $3,200 
13-12-2018   $2,900 
14-08-2018   $2,750 
15-08-2018   $2,875

现在，我正在使用帮助器列和公式组合来提取唯一的月份。我也可以使用Pivot Table来做到这一点。但是我需要对这些数据进行一些分析，因为在我的实际数据中有很多列，并且还需要其他一些报告。因此，如果有人可以帮助我完成这些工作而没有帮助者专栏和Pivot Table。如果内置函数无法实现，UDF是第二选择。

Answer 1

在此示例中，我使用了Sheet1，结果粘贴在Sheet2中

尝试：

Public Sub Get_Unique_Count_Paste_Array()

Dim Ob As Object
Dim rng As Range
Dim Item As Variant
Dim str As String
Dim r As Long
Dim Date_ As String
Dim Amount_ As Double

r = 1

Set Ob = CreateObject("scripting.dictionary")


LR = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row

For Each rng In Sheet1.Range("A2:A" & LR)
    Date_ = Format(rng.Value, "mmm-yy")
    Amount_ = Right(rng.Offset(0, 1).Value, Len(rng.Offset(0, 1).Value) - 1)

    If Len(Date_) > 0 Then
        str = Date_
        Ob(Date_) = Ob(Date_) + Amount_
    End If
Next rng

For Each Item In Ob.keys

    With Worksheets("Sheet2")

        .Cells(r, 1).Value = Item
        With .Cells(r, 2)
            .Value = Ob(Item)
            .NumberFormat = "[$$-en-US]#,##0.00"
        End With

    End With

    r = r + 1

Next Item

End Sub

Answer 2

在数据透视表中，单击包含日期的单元格，从菜单中选择“组”，然后选择“月份”步骤。

Answer 3

Monthify

在使用代码之前，仔细研究定制部分。一个严重的限制是，两个列对中的每对都包含 adjacent 列，实现这些列是为了跳过范围内的循环。

Option Explicit

Sub Monthify()

'**** Customize BEGIN ******************
  Const cStrDateCol As String = "B"     ' Column Letter of the Date
  Const cStrSalesCol As String = "C"    ' Column Letter of the Sales
  Const cStrMonthCol As String = "E"    ' Column Letter of the Resulting Month
  Const cStrTotalCol As String = "F"    ' Column Letter of the Resulting Sales
  Const cLngFirstRow As Long = 4        ' First Row of Initial Data
  Const cLngFirstRowResult As Long = 4  ' First Row of Resulting Data
  Const cLngLastRow As Long = 0         ' Last Row (If 0, it is calculated.)
  Const cStrSheet = "Sheet1"            ' Sheet Name. If "", then ActiveSheet.
  Const cStrMonth1 As String = "MMM"    ' Month Format Part 1
  Const cStrMonth2 As String = "-"      ' Month Format Part 2
  Const cStrMonth3 As String = "YY"     ' Month Format Part 3
'**** Customize END ********************

  Dim objWs As Worksheet

  Dim arrInit As Variant      ' Initial Array
  Dim arrResult As Variant    ' Resulting Array
  Dim lngLastRow As Long      ' Last Row Calculator
  Dim lngArr As Long          ' Array Row Counter
  Dim lngArr2 As Long         ' Array Additional Sort Row Counter
  Dim iArr As Integer         ' Array Columns Counter
  Dim vntArr As Variant       ' Array Temporary Variable
  Dim lngUnique As Long       ' (Unique) Months Count(er)
'*******************************************************************************
' Objects

  ' In Workbook
  With ThisWorkbook
    If cStrSheet <> "" Then
      Set objWs = .Worksheets(cStrSheet)
     Else
      Set objWs = .ActiveSheet
    End If
  End With

  ' In Worksheet
  With objWs
    ' Define last row of data.
    If cLngLastRow <> 0 Then ' Last row is defined.
      lngLastRow = cLngLastRow
     Else ' Last row isn't defined, has to be calculated.
      If .Cells(.Rows.Count, cStrDateCol) = "" Then ' Last cell is empty.
        lngLastRow = .Cells(.Rows.Count, cStrDateCol).End(xlUp).Row
       Else ' Last cell is not empty.
        lngLastRow = .Cells(.Rows.Count, cStrDateCol).Row
      End If
    End If
    ' Paste data into array.
    arrInit = Union(.Range( _
        Cells(cLngFirstRow, cStrDateCol), _
        Cells(lngLastRow, cStrDateCol)), .Range( _
        Cells(cLngFirstRow, cStrSalesCol), _
        Cells(lngLastRow, cStrSalesCol))).Value2
  End With

'*******************************************************************************
' Arrays

  ' Sort initial array by date ascending.
  For lngArr = LBound(arrInit) To UBound(arrInit)
    For lngArr2 = lngArr + 1 To UBound(arrInit)
      If arrInit(lngArr, 1) > arrInit(lngArr2, 1) Then
        For iArr = 1 To 2
          vntArr = arrInit(lngArr2, iArr)
          arrInit(lngArr2, iArr) = arrInit(lngArr, iArr)
          arrInit(lngArr, iArr) = vntArr
        Next
      End If
    Next
  Next

  ' Convert date to months-year string.
  For lngArr = LBound(arrInit) To UBound(arrInit)
    arrInit(lngArr, 1) = WorksheetFunction.Proper(Format(arrInit(lngArr, 1), _
    cStrMonth1)) & cStrMonth2 & Format(arrInit(lngArr, 1), cStrMonth3)
  Next

  ' Count the number of unique month-year strings to determine the resulting
  ' array's size.
  vntArr = ""
  For lngArr = LBound(arrInit) To UBound(arrInit)
    If vntArr <> arrInit(lngArr, 1) Then
      vntArr = arrInit(lngArr, 1)
      lngUnique = lngUnique + 1
    End If
  Next

  ' Resize resulting array.
  ReDim arrResult(1 To lngUnique, 1 To 2)

  ' Write first column to resulting array.
  vntArr = ""
  lngUnique = 0
  For lngArr = LBound(arrInit) To UBound(arrInit)
    If vntArr <> arrInit(lngArr, 1) Then
      vntArr = arrInit(lngArr, 1)
      lngUnique = lngUnique + 1
      arrResult(lngUnique, 1) = arrInit(lngArr, 1)
    End If
  Next

  ' Write second column to resulting array.
  For lngArr2 = LBound(arrResult) To UBound(arrResult)
    vntArr = 0
    For lngArr = LBound(arrInit) To UBound(arrInit)
      If arrResult(lngArr2, 1) = arrInit(lngArr, 1) Then
        vntArr = vntArr + arrInit(lngArr, 2)
      End If
    Next
    arrResult(lngArr2, 2) = vntArr
  Next

'*******************************************************************************
'Objects

  ' Paste array into range.
  With objWs
    Union(.Range( _
        Cells(cLngFirstRowResult, cStrMonthCol), _
        Cells(cLngFirstRowResult + lngUnique - 1, cStrMonthCol)), .Range( _
        Cells(cLngFirstRowResult, cStrTotalCol), _
        Cells(cLngFirstRowResult + lngUnique - 1, cStrTotalCol))) = arrResult
  End With

  Set objWs = Nothing

End Sub

从年份中提取唯一的月份

3 个答案:

Monthify