[已解决]汇总出错，望修改一下代码

171774040

请看附件，谢谢 44.rar (59.78 KB, 下载次数: 9)

2016-2-26 21:13 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

JX_shangrila

2016-2-26 22:41

按您代码思路修改
Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  Set d1 = CreateObject("scripting.dictionary")
  m = 1
  For Each aa In Array("东", "南", "西", "东北")
    m = m + 1
    d1(aa) = m
  Next
  With Worksheets("数据源")
    r = .Cells(.Rows.Count, 2).End(xlUp).Row
    arr = .Range("a4:h" & r)
    For i = 1 To UBound(arr)
      xm = Format(arr(i, 2), "yyyy年m月")
      ts = Day(DateSerial(Year(arr(i, 2)), Month(arr(i, 2)) + 1, 0))
      If Not d.exists(xm) Then
        ReDim brr(1 To 5, 1 To ts + 1)
        brr(1, 1) = "名称"
        For j = 1 To ts
          brr(1, j + 1) = j & "日"
        Next
        m = 1
        For Each aa In d1.keys
          m = m + 1
          brr(m, 1) = aa
        Next
        If d1.exists(arr(i, 4)) Then
          m = d1(arr(i, 4))
          n = Day(arr(i, 2))
          brr(m, n + 1) = brr(m, n + 1) + arr(i, 8)
        End If
      Else
        brr = d(xm)
        If d1.exists(arr(i, 4)) Then
          m = d1(arr(i, 4))
          n = Day(arr(i, 2))
          brr(m, n + 1) = brr(m, n + 1) + arr(i, 8)
        End If
      End If
      d(xm) = brr   
    Next
  End With
  m = 1
  With Worksheets("表格")
    .Cells.Clear
    For Each aa In d.keys
      brr = d(aa)
      With .Cells(m, 1)
        .Value = aa
        .Resize(1, 32).Merge
        .HorizontalAlignment = xlCenter
      End With
      .Cells(m + 1, 1).Resize(5, UBound(brr, 2)) = brr
      .Cells(m, 1).Resize(6, 32).Borders.LineStyle = xlContinuous
      m = m + 8
    Next
  End With
End Sub

跳转到最佳答案楼层

JX_shangrila

按您代码思路修改
Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  Set d1 = CreateObject("scripting.dictionary")
  m = 1
  For Each aa In Array("东", "南", "西", "东北")
    m = m + 1
    d1(aa) = m
  Next
  With Worksheets("数据源")
    r = .Cells(.Rows.Count, 2).End(xlUp).Row
    arr = .Range("a4:h" & r)
    For i = 1 To UBound(arr)
      xm = Format(arr(i, 2), "yyyy年m月")
      ts = Day(DateSerial(Year(arr(i, 2)), Month(arr(i, 2)) + 1, 0))
      If Not d.exists(xm) Then
        ReDim brr(1 To 5, 1 To ts + 1)
        brr(1, 1) = "名称"
        For j = 1 To ts
          brr(1, j + 1) = j & "日"
        Next
        m = 1
        For Each aa In d1.keys
          m = m + 1
          brr(m, 1) = aa
        Next
        If d1.exists(arr(i, 4)) Then
          m = d1(arr(i, 4))
          n = Day(arr(i, 2))
          brr(m, n + 1) = brr(m, n + 1) + arr(i, 8)
        End If
      Else
        brr = d(xm)
        If d1.exists(arr(i, 4)) Then
          m = d1(arr(i, 4))
          n = Day(arr(i, 2))
          brr(m, n + 1) = brr(m, n + 1) + arr(i, 8)
        End If
      End If
      d(xm) = brr   
    Next
  End With
  m = 1
  With Worksheets("表格")
    .Cells.Clear
    For Each aa In d.keys
      brr = d(aa)
      With .Cells(m, 1)
        .Value = aa
        .Resize(1, 32).Merge
        .HorizontalAlignment = xlCenter
      End With
      .Cells(m + 1, 1).Resize(5, UBound(brr, 2)) = brr
      .Cells(m, 1).Resize(6, 32).Borders.LineStyle = xlContinuous
      m = m + 8
    Next
  End With
End Sub

171774040

JX_shangrila 发表于 2016-2-26 22:41
按您代码思路修改
Sub test()
  Dim r%, i%

谢谢~~~~~~~~~~