VBA实现Excel房间预订信息提取并输出至Word表格需求

背景与需求 #

本人不擅长VBA，正在尝试自动化房间预订相关工作。Excel中房间号位于B5:B511列，日期位于E3:NF3行，已可通过预订号（Listennummer）匹配获取对应单元格的行列号，但仍需实现以下功能：

• 从E3:NF3返回日期而非单元格行列号（已完成）
• 仅返回每个房间预订的起始与结束日期
• 将结果输出至Word文档指定位置的3列表格（列名：Roomnumber、Start date、End date），可使用Bookmarks或Tables.Add方法

示例与当前问题 #

输入预订号140，期望输出：
A2行：1008，B2行：01.01，C2行：02.01；
A3行：1012，B3行：02.01，C3行：04.01。

当前代码输出为每日重复的房间与日期信息：

01.01.2024 
Roomnumber 1008
02.01.2024 
Roomnumber 1008
03.01.2024 
Roomnumber 1008
03.01.2024 
Roomnumber 1010
04.01.2024 
Roomnumber 1010

现有代码 #

Sub ConfirmationWithRooms()
Dim ListennummerFileName As String
Listennummer = InputBox("Bestätigung erstellen", "Reservationsbestätigung", "Listennummer eingeben")
On Error Resume Next
ListennummerCell = Worksheets("Bestätigung").Range("A3:A9999").Find(Listennummer).Address
If Err.Number = 91 Then
MsgBox "Listennummer existiert nicht"
GoTo Ender
End If


'Juicy Part

Worksheets("Kalender").Activate
Dim Rng As Range
Dim DateDayInterger As Integer
Dim DateOutputFloat As Date
Set Rng = Range("E4:I15")
Dim FindRng As Range
Set FindRng = Rng.Find(What:=Listennummer)
Dim FirstCell As String
Dim DateOfCell As String
Dim TowInteger As Integer
Dim RoomNumber As String
Dim RoomNumberInteger As Integer
FirstCell = FindRng.Address
OurYear = DateSerial(2024, 1, 1)
Do
Datedayinteger = FindRng.Column - 5
RoomNumberInteger = FindRng.Row - 5
DateOutputFloat = OurYear + Datedayinteger
RoomNumber = Range("B5").Offset(RoomNumberInteger, 0)
Debug.Print DateOutputFloat
Debug.Print "Roomnumber " & RoomNumber
  Set FindRng = Rng.FindNext(FindRng)
  Loop While FirstCell <> FindRng.Address

'End juicy part

Set Wordapp = CreateObject("word.Application")
    Wordapp.Documents.Open "M:\Teams\ReservationWord.docx"
    Wordapp.Visible = True
    Wordapp.Activate
    Application.Wait (Now + TimeValue("00:00:05"))
'Can throw errors without Wait
    ActiveDocument.Bookmarks("Listennummer").Range.Text = Listennummer
    ActiveDocument.Bookmarks("BestellerEmail").Range.Text = BestellerEmail
    ActiveDocument.Bookmarks("BestellerName").Range.Text = BestellerName
    ActiveDocument.Bookmarks("BestellerTelefon").Range.Text = BestellerTelefon
    ActiveDocument.Bookmarks("Bestelltam").Range.Text = Bestelltam
    ActiveDocument.Bookmarks("BestelltfuerName").Range.Text = BestelltfuerName
    ActiveDocument.Bookmarks("BestelltfuerEmail").Range.Text = BestelltfuerEmail
    ActiveDocument.Bookmarks("BestelltfuerTelefon").Range.Text = BestelltfuerTelefon
    ActiveDocument.Bookmarks("Bestelltvia").Range.Text = Bestelltvia
'Tables.Add?
Ender:
End Sub

优化后的解决方案 #

核心修改点 #

1. 使用字典按房间号分组，自动记录每个房间的最早（起始）和最晚（结束）日期
2. 在Word指定书签位置创建表格，将整理好的预订数据批量填入

修改后的完整代码 #

Sub ConfirmationWithRooms()
    Dim Listennummer As String
    Listennummer = InputBox("Bestätigung erstellen", "Reservationsbestätigung", "Listennummer eingeben")
    
    On Error Resume Next
    Dim ListennummerCell As Range
    Set ListennummerCell = Worksheets("Bestätigung").Range("A3:A9999").Find(Listennummer)
    If Err.Number = 91 Then
        MsgBox "Listennummer existiert nicht"
        GoTo Ender
    End If
    On Error GoTo 0 ' 恢复正常错误捕获
    
    ' --- 收集房间预订起止日期 ---
    Dim wsKalender As Worksheet
    Set wsKalender = Worksheets("Kalender")
    
    Dim Rng As Range
    Set Rng = wsKalender.Range("E4:NF511") ' 覆盖所有房间和日期范围
    
    Dim FindRng As Range
    Set FindRng = Rng.Find(What:=Listennummer, LookIn:=xlValues, LookAt:=xlWhole)
    If FindRng Is Nothing Then
        MsgBox "Keine Buchungen für diese Listennummer gefunden"
        GoTo Ender
    End If
    
    Dim FirstCell As String
    FirstCell = FindRng.Address
    
    ' 字典存储房间预订：Key=房间号，Item=数组(起始日期, 结束日期)
    Dim roomBookings As Object
    Set roomBookings = CreateObject("Scripting.Dictionary")
    
    Dim currentRoom As String
    Dim currentDate As Date
    Dim OurYear As Date
    OurYear = DateSerial(2024, 1, 1)
    
    Do
        ' 计算当前单元格对应的日期
        currentDate = OurYear + (FindRng.Column - 5)
        ' 获取当前单元格对应的房间号
        currentRoom = wsKalender.Range("B" & FindRng.Row).Value
        
        If roomBookings.Exists(currentRoom) Then
            ' 更新结束日期（取较大值）
            If currentDate > roomBookings(currentRoom)(1) Then
                roomBookings(currentRoom)(1) = currentDate
            End If
            ' 更新起始日期（取较小值）
            If currentDate < roomBookings(currentRoom)(0) Then
                roomBookings(currentRoom)(0) = currentDate
            End If
        Else
            ' 首次记录该房间，起止日期暂设为当前日期
            roomBookings.Add currentRoom, Array(currentDate, currentDate)
        End If
        
        Set FindRng = Rng.FindNext(FindRng)
    Loop While FindRng.Address <> FirstCell
    
    ' --- 输出到Word文档 ---
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim targetBookmark As Object
    Dim bookingTable As Object
    Dim rowIdx As Integer
    
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open("M:\Teams\ReservationWord.docx")
    WordApp.Visible = True
    
    ' 定位到表格插入位置的书签（需提前在Word中创建名为BookingTableLocation的书签）
    On Error Resume Next
    Set targetBookmark = WordDoc.Bookmarks("BookingTableLocation")
    If Err.Number <> 0 Then
        MsgBox "Bookmark nicht gefunden"
        WordDoc.Close SaveChanges:=False
        WordApp.Quit
        GoTo Ender
    End If
    On Error GoTo 0
    
    ' 创建表格：行数=房间数+1（表头），列数=3
    Set bookingTable = WordDoc.Tables.Add(Range:=targetBookmark.Range, _
        NumRows:=roomBookings.Count + 1, NumColumns:=3)
    
    ' 设置表头样式
    bookingTable.Cell(1, 1).Range.Text = "Roomnumber"
    bookingTable.Cell(1, 2).Range.Text = "Start date"
    bookingTable.Cell(1, 3).Range.Text = "End date"
    bookingTable.Rows(1).Range.Bold = True
    
    ' 填充房间预订数据
    rowIdx = 2
    Dim key As Variant
    For Each key In roomBookings.Keys
        bookingTable.Cell(rowIdx, 1).Range.Text = key
        ' 日期格式化为dd.mm
        bookingTable.Cell(rowIdx, 2).Range.Text = Format(roomBookings(key)(0), "dd.mm")
        bookingTable.Cell(rowIdx, 3).Range.Text = Format(roomBookings(key)(1), "dd.mm")
        rowIdx = rowIdx + 1
    Next key
    
    ' 重新添加书签（避免表格插入后书签丢失）
    WordDoc.Bookmarks.Add Name:="BookingTableLocation", Range:=bookingTable.Range
    
    ' 填充其他预订信息（原代码逻辑保留）
    WordDoc.Bookmarks("Listennummer").Range.Text = Listennummer
    WordDoc.Bookmarks("BestellerEmail").Range.Text = BestellerEmail
    WordDoc.Bookmarks("BestellerName").Range.Text = BestellerName
    WordDoc.Bookmarks("BestellerTelefon").Range.Text = BestellerTelefon
    WordDoc.Bookmarks("Bestelltam").Range.Text = Bestelltam
    WordDoc.Bookmarks("BestelltfuerName").Range.Text = BestelltfuerName
    WordDoc.Bookmarks("BestelltfuerEmail").Range.Text = BestelltfuerEmail
    WordDoc.Bookmarks("BestelltfuerTelefon").Range.Text = BestelltfuerTelefon
    WordDoc.Bookmarks("Bestelltvia").Range.Text = Bestelltvia
    
Ender:
    ' 释放所有对象，避免内存泄漏
    Set bookingTable = Nothing
    Set targetBookmark = Nothing
    Set WordDoc = Nothing
    Set WordApp = Nothing
    Set roomBookings = Nothing
    Set FindRng = Nothing
    Set Rng = Nothing
    Set wsKalender = Nothing
    Set ListennummerCell = Nothing
End Sub

注意事项 #

• 需提前在Word文档中创建名为BookingTableLocation的书签，用于指定表格插入位置
• 代码中年份固定为2024，若需适配其他年份，修改OurYear = DateSerial(2024, 1, 1)即可
• 确保BestellerEmail等变量已在代码其他部分定义（原代码未显示定义，需自行补充）

内容的提问来源于stack exchange，提问作者Nekkusu