使用 VBA 将表格中的每周数据转换为特定范围的每月数据

Question

我有一系列每周数据需要转换成每月数据。在 VBA 方面，我是一个初学者。我找到了一个以前的问题线程：https://stackoverflow.com/ 有一个类似的问题。该代码是为项目类型位于 A 列且日期从 B 列开始时编写的。我需要将代码用于指定范围的列。我不知道如何让它在特定范围内工作。

提供的代码大部分对我有用。问题是我的系统有一大堆系统生成的信息列 B:Q，不允许我删除我的管理。他们还想看。

我已经尝试为要运行的数据设置一个特定的范围，但是当它到达代码的粗体部分中的第一个非月份单元格时，会一直出错。我还尝试更改代码读取月份的方式，但最终给我一条错误消息或跳过月份。

有人知道我如何让它在特定范围 R:AC 上工作吗？

这是我最好的尝试：

Sub SumByMonth()

    Dim wb As Workbook, ws As Worksheet
    Dim LastCol As Long, LastRow As Long, c As Long, n As Long
    Dim dt As Date
    Dim Myrange As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    Set Myrange = Range("R1:AC1")
    
    LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

**    **' scan cols from right to left insert new columns
    Application.ScreenUpdating = False
    For c = LastCol + 1 To 3 Step -1
        ' add columns on month change
        If Month(ws.Cells(1, c)) <> Month(ws.Cells(1, c - 1)) Then
             ws.Columns(c).Insert
             With ws.Columns(c)
                .HorizontalAlignment = xlCenter
                '.Interior.Color = RGB(255, 255, 200)
                .Font.Bold = True
                .Cells(1).NumberFormat = "@"
             End With
        End If****
    Next

    ' scan left to right filling new cols with sum() formula
    ' hide weekly columns
    LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    n = 0
    For c = 2 To LastCol + 1
       If ws.Cells(1, c) = "" Then
          dt = ws.Cells(1, c - 1)
          ws.Cells(1, c) = MonthName(Month(dt), True) & "  " & Year(dt)
          ws.Cells(2, c).Resize(LastRow - 1).FormulaR1C1 = "=SUM(RC[-" & n & "]:RC[-1])"
          n = 0
       Else
          ws.Columns(c).EntireColumn.Hidden = True
          n = n + 1
       End If
    Next

     
    ' end
    ws.Columns.Hidden = False
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "Done"

End Sub

我已经突出显示了我希望它看起来像的列。

Answer 1

只需用常量替换硬编码的开始列

Option Explicit

Sub SumByMonth()

    Const STARTCOL = 18 ' R
    Dim wb As Workbook, ws As Worksheet
    Dim LastCol As Long, LastRow As Long, c As Long, n As Long
    Dim dt As Date
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    With ws
       LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
       LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

   ' scan cols from right to left insert new columns
    Application.ScreenUpdating = False
    For c = LastCol + 1 To STARTCOL + 1 Step -1
        ' add columns on month change
        If Month(ws.Cells(1, c)) <> Month(ws.Cells(1, c - 1)) Then
             ws.Columns(c).Insert
             With ws.Columns(c)
                .HorizontalAlignment = xlCenter
                '.Interior.Color = RGB(255, 255, 200)
                .Font.Bold = True
                .Cells(1).NumberFormat = "@"
             End With
        End If
    Next

    ' scan left to right filling new cols with sum() formula
    LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    n = 0
    For c = STARTCOL To LastCol + 1
       If ws.Cells(1, c) = "" Then
            dt = ws.Cells(1, c - 1)
            ws.Cells(1, c) = MonthName(Month(dt), True) & "  " & Year(dt)
            With ws.Cells(2, c).Resize(LastRow - 1)
                .FormulaR1C1 = "=SUM(RC[-" & n & "]:RC[-1])"
                .Interior.Color = RGB(255, 255, 200)
            End With
            n = 0
       Else
            n = n + 1
       End If
    Next
    
    ' end
    ws.Columns.Hidden = False
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "Done"

End Sub