VBA宏代码修复请求：排序异常与格式复制失效问题

问题原因与修复方案 #

1. D列数值排序异常 #

原代码中D列数据以文本格式存储，导致排序按文本字典序执行（如15排在7前面）；且LD by Day中直接对普通区域排序，未识别为结构化表格，排序逻辑不准确。

修复要点：

• 在Schedule by LD排序前，强制将D列转为数值格式
• LD by Day中复制数据后，将目标区域转换为ListObject表格，再针对表格列执行排序

2. 单元格格式复制失败 #

原代码复制底色时错误引用了目标单元格的DisplayFormat，应改为取源单元格的格式；且逐个单元格循环效率低下，改用PasteSpecial批量复制格式更可靠。

修复要点：

• 替换手动循环格式复制的代码，使用xlPasteFormats批量同步所有样式（底色、字体颜色、边框等）
• 先复制值再粘贴格式，确保内容与样式完全匹配

完整修正后的VBA代码 #

Option Explicit

Sub TransferAndSortTable()
    On Error GoTo ErrorHandler

    Dim lastTable As ListObject
    Dim lastTableName As String
    Dim maxTableNum As Long
    Dim tableNum As Long
    Dim tableName As String
    Dim tableLD As ListObject
    Dim wsLD As Worksheet
    Dim wsLDbyDay As Worksheet
    Dim colIndex As Long
    Dim col As Variant
    Dim sourceRange As Range
    Dim targetRange As Range

    ' 检查工作表是否存在
    If Not SheetExists("Schedule by Date") Then
        MsgBox "工作表'Schedule by Date'不存在。", vbExclamation
        Exit Sub
    End If
    If Not SheetExists("Schedule by LD") Then
        MsgBox "工作表'Schedule by LD'不存在。", vbExclamation
        Exit Sub
    End If
    If Not SheetExists("LD by Day") Then
        MsgBox "工作表'LD by Day'不存在。", vbExclamation
        Exit Sub
    End If

    ' 设置工作表引用
    Set wsLD = Sheets("Schedule by LD")
    Set wsLDbyDay = Sheets("LD by Day")

    ' 复制"Schedule by Date"的Table1到"Schedule by LD"
    Sheets("Schedule by Date").ListObjects("Table1").Range.Copy
    wsLD.Range("A1").PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False
    wsLD.Columns("A:I").EntireColumn.AutoFit

    ' 查找"Schedule by LD"中最新的表格
    maxTableNum = 0
    For Each tableLD In wsLD.ListObjects
        tableName = tableLD.Name
        If Left(tableName, 5) = "Table" Then
            tableNum = CLng(Mid(tableName, 6))
            If tableNum > maxTableNum Then
                maxTableNum = tableNum
                lastTableName = tableName
            End If
        End If
    Next tableLD

    If lastTableName = "" Then
        MsgBox "在'Schedule by LD'中未找到表格。", vbExclamation
        Exit Sub
    End If

    ' 验证最新表格中存在"LD"列
    Dim colFound As Boolean
    colFound = False
    For Each col In wsLD.ListObjects(lastTableName).ListColumns
        If col.Name = "LD" Then
            colIndex = col.Index
            colFound = True
            Exit For
        End If
    Next col

    If Not colFound Then
        MsgBox "表格'" & lastTableName & "'中不存在'LD'列。", vbExclamation
        Exit Sub
    End If

    ' 强制转换LD列为数值格式（修复排序问题）
    With wsLD.ListObjects(lastTableName).ListColumns(colIndex).DataBodyRange
        .NumberFormat = "General"
        .Value = .Value
    End With

    ' 按LD列升序排序"Schedule by LD"中的表格
    With wsLD.ListObjects(lastTableName).Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsLD.ListObjects(lastTableName).ListColumns(colIndex).Range, _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
    End With

    ' 清除"LD by Day"原有内容（避免重复）
    wsLDbyDay.Cells.Clear

    ' 复制排序后的数据到"LD by Day"
    Set sourceRange = wsLD.ListObjects(lastTableName).Range
    Set targetRange = wsLDbyDay.Range("A1").Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)

    ' 复制值和格式（替换原手动循环）
    sourceRange.Copy
    targetRange.PasteSpecial Paste:=xlPasteValues
    targetRange.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False

    ' 将目标区域转为ListObject表格
    wsLDbyDay.ListObjects.Add(xlSrcRange, targetRange, , xlYes).Name = "LDbyDayTable"

    ' 在"LD by Day"的表格中按D列（LD列）升序排序
    With wsLDbyDay.ListObjects("LDbyDayTable").Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsLDbyDay.ListObjects("LDbyDayTable").ListColumns("LD").Range, _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
    End With

    ' 自动调整列宽
    wsLDbyDay.Columns("A:I").EntireColumn.AutoFit

    Exit Sub

ErrorHandler:
    MsgBox "发生错误: " & Err.Description, vbExclamation
End Sub

' 检查工作表是否存在的函数
Function SheetExists(sheetName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Worksheets(sheetName) Is Nothing
    On Error GoTo 0
End Function

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