多岛屿酒店数据跨工作表合并VBA需求及实现代码

我拥有6个以岛屿名称（安提瓜、巴巴多斯、格林纳达、牙买加、圣卢西亚、圣文森特）命名的Excel工作表，每个工作表包含酒店、星级、各月总客房入住数、备注等数据（表头示例：酒店、星级、Jan-24、Feb-24……Dec-25、备注）。需通过VBA代码将各表数据整合至新工作表，新表表头为：酒店名称、星级、岛屿名称、月份、年份、季度、总客房入住数、备注。

实现代码 #

Option Explicit
Sub ConsolidateData()
Dim ws As Worksheet
Dim masterWs As Worksheet
Dim lastRow As Long, lastCol As Long
Dim i As Long, j As Long
Dim RowCnt As Long
Dim monthYear As String
Dim cell As Range

' 添加用于存放整合数据的新工作表
On Error Resume Next
Set masterWs = ThisWorkbook.Sheets("Consolidated")
If masterWs Is Nothing Then
    Set masterWs = ThisWorkbook.Sheets.Add
    masterWs.Name = "Consolidated"
End If
On Error GoTo 0

' 写入整合表的表头
masterWs.Cells.Clear
' 输出表的表头数组
Dim aHeader: aHeader = Array("酒店名称", "星级", "月份", "年份", "季度", "岛屿名称", "总客房入住数", "备注")
' 填充表头行
masterWs.Range("A1").Resize(1, UBound(aHeader) + 1).Value = aHeader

' 计算输出表的行数
For Each ws In ThisWorkbook.Sheets
    If ws.Name <> masterWs.Name Then
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        RowCnt = RowCnt + (lastRow - 1) * lastCol
    End If
Next
Dim arrRes(): ReDim arrRes(1 To RowCnt, 1 To UBound(aHeader) + 1)
RowCnt = 1
' 遍历所有工作表
Dim arrData, r As Range
For Each ws In ThisWorkbook.Sheets
    If ws.Name <> masterWs.Name Then
        ' 获取当前表的最后一行和最后一列
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set r = ws.Range("A1", ws.Cells(lastRow, lastCol))
        arrData = r.Value
        ' 遍历当前表的数据行（从第2行开始跳过表头）
        For i = 2 To lastRow
            ' 遍历月份列（从第3列开始）
            For j = 3 To lastCol
                If Len(Trim(arrData(i, j))) > 0 Then
                    ' 处理日期格式
                    If IsDate(arrData(1, j)) Then
                        monthYear = Format(CDate(arrData(1, j)), "MMM-yyyy")
                        ' 填充整合数据数组
                        arrRes(RowCnt, 1) = arrData(i, 1) ' 酒店名称
                        arrRes(RowCnt, 2) = arrData(i, 2) ' 星级
                        arrRes(RowCnt, 3) = Split(monthYear, "-")(0) ' 月份
                        arrRes(RowCnt, 4) = Split(monthYear, "-")(1) ' 年份
                        arrRes(RowCnt, 5) = Application.RoundUp(Month(CDate(arrData(1, j))) / 3, 0) ' 季度
                    Else
                        arrRes(RowCnt, 3) = "无效日期"
                        arrRes(RowCnt, 4) = "无效年份"
                        arrRes(RowCnt, 5) = "无效季度"
                        Debug.Print "表头第" & j & "列存在无效日期: " & arrData(1, j)
                    End If
                    arrRes(RowCnt, 6) = ws.Name ' 岛屿名称
                    arrRes(RowCnt, 7) = arrData(i, j) ' 总客房入住数
                    RowCnt = RowCnt + 1
                End If
            Next j
        Next i
    End If
Next ws
If RowCnt > 1 Then
    masterWs.Range("A2").Resize(RowCnt - 1, UBound(aHeader)).Value = arrRes
End If
MsgBox "数据整合完成!", vbInformation
End Sub

原工作表示例数据 #

目标整合表示例数据 #

内容的提问来源于stack exchange，提问作者james falcus Jamesfalc