excel - CopyPaste Cell Formatting AND Sort Ascending Numerically - Stack Overflow

admin管理员组

文章数量:1123768

The issues involved in the macro code follows as :

• Sheets "Schedule by LD" and "Ld by Day", Column D is not being sorted ascending/numerically. When sorted the numbers are arranged as: 1 1 15 15 7 9 20 20

  The sort should show as : 1 1 7 9 15 15 20 20 (These numbers are not the actual in the workbook but only an example to understand)

• Secondly, the macro fails to properly copy/paste the colored text and cell interior colors from "Schedule by LD" to "Ld by Day"

The lines of code re: copying the cell formatting is located between the two commented lines shown like : '#######################################

Your assistance is greatly appreciated in correcting this macro code.

The sample workbook may be downloaded here : Copy Paste Sort Cols Sheets

    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
    Dim cell As Range
    Dim targetCell As Range

    ' Check if the sheets exist
    If Not SheetExists("Schedule by Date") Then
        MsgBox "The sheet 'Schedule by Date' does not exist.", vbExclamation
        Exit Sub
    End If
    If Not SheetExists("Schedule by LD") Then
        MsgBox "The sheet 'Schedule by LD' does not exist.", vbExclamation
        Exit Sub
    End If
    If Not SheetExists("LD by Day") Then
        MsgBox "The sheet 'LD by Day' does not exist.", vbExclamation
        Exit Sub
    End If

    ' Set worksheet references
    Set wsLD = Sheets("Schedule by LD")
    Set wsLDbyDay = Sheets("LD by Day")

    ' Copy Table1 from "Schedule by Date" to "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

    ' Find the latest table in "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 "No table found in 'Schedule by LD'.", vbExclamation
        Exit Sub
    End If

    ' Verify "LD" column exists in the latest table
    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 "The column 'LD' does not exist in the table '" & lastTableName & "'.", vbExclamation
        Exit Sub
    End If

    ' Sort "Schedule by LD" table by LD column
    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

    ' Copy the sorted data to "LD by Day"
    Set sourceRange = wsLD.ListObjects(lastTableName).Range
    Set targetRange = wsLDbyDay.Range("A1").Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)

    ' Copy values
    targetRange.Value = sourceRange.Value


'################################################################################################################

    ' Copy formats manually
    For Each cell In sourceRange
        Set targetCell = targetRange.Cells(cell.Row - sourceRange.Row + 1, cell.Column - sourceRange.Column + 1)
        With targetCell
            
            .Interior.Color = .DisplayFormat.Interior.Color ' Copy cell background color
            .Font.Color = cell.Font.Color ' Copy text color
            .Font.Bold = cell.Font.Bold ' Copy bold property
            .Borders.LineStyle = cell.Borders.LineStyle ' Copy border styles
        End With
    Next cell
    
'################################################################################################################


    ' Ensure column D is treated as numeric
    Dim lastRow As Long
    lastRow = wsLDbyDay.Cells(wsLDbyDay.Rows.Count, "D").End(xlUp).Row
    wsLDbyDay.Range("D2:D" & lastRow).NumberFormat = "General"
    wsLDbyDay.Range("D2:D" & lastRow).Value = wsLDbyDay.Range("D2:D" & lastRow).Value ' Force conversion to numbers

    ' Sort column D in "LD by Day"
    With wsLDbyDay.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsLDbyDay.Range("D2:D" & lastRow), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal
        .SetRange wsLDbyDay.Range("A1:I" & lastRow) ' Include full table
        .Header = xlYes
        .Apply
    End With

    ' Autofit columns in "LD by Day"
    wsLDbyDay.Columns("A:I").EntireColumn.AutoFit

    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub

' Function to check if a sheet exists
Function SheetExists(sheetName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Worksheets(sheetName) Is Nothing
    On Error GoTo 0
End Function

The issues involved in the macro code follows as :

• Sheets "Schedule by LD" and "Ld by Day", Column D is not being sorted ascending/numerically. When sorted the numbers are arranged as: 1 1 15 15 7 9 20 20

  The sort should show as : 1 1 7 9 15 15 20 20 (These numbers are not the actual in the workbook but only an example to understand)

• Secondly, the macro fails to properly copy/paste the colored text and cell interior colors from "Schedule by LD" to "Ld by Day"

The lines of code re: copying the cell formatting is located between the two commented lines shown like : '#######################################

Your assistance is greatly appreciated in correcting this macro code.

The sample workbook may be downloaded here : Copy Paste Sort Cols Sheets

    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
    Dim cell As Range
    Dim targetCell As Range

    ' Check if the sheets exist
    If Not SheetExists("Schedule by Date") Then
        MsgBox "The sheet 'Schedule by Date' does not exist.", vbExclamation
        Exit Sub
    End If
    If Not SheetExists("Schedule by LD") Then
        MsgBox "The sheet 'Schedule by LD' does not exist.", vbExclamation
        Exit Sub
    End If
    If Not SheetExists("LD by Day") Then
        MsgBox "The sheet 'LD by Day' does not exist.", vbExclamation
        Exit Sub
    End If

    ' Set worksheet references
    Set wsLD = Sheets("Schedule by LD")
    Set wsLDbyDay = Sheets("LD by Day")

    ' Copy Table1 from "Schedule by Date" to "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

    ' Find the latest table in "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 "No table found in 'Schedule by LD'.", vbExclamation
        Exit Sub
    End If

    ' Verify "LD" column exists in the latest table
    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 "The column 'LD' does not exist in the table '" & lastTableName & "'.", vbExclamation
        Exit Sub
    End If

    ' Sort "Schedule by LD" table by LD column
    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

    ' Copy the sorted data to "LD by Day"
    Set sourceRange = wsLD.ListObjects(lastTableName).Range
    Set targetRange = wsLDbyDay.Range("A1").Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)

    ' Copy values
    targetRange.Value = sourceRange.Value


'################################################################################################################

    ' Copy formats manually
    For Each cell In sourceRange
        Set targetCell = targetRange.Cells(cell.Row - sourceRange.Row + 1, cell.Column - sourceRange.Column + 1)
        With targetCell
            
            .Interior.Color = .DisplayFormat.Interior.Color ' Copy cell background color
            .Font.Color = cell.Font.Color ' Copy text color
            .Font.Bold = cell.Font.Bold ' Copy bold property
            .Borders.LineStyle = cell.Borders.LineStyle ' Copy border styles
        End With
    Next cell
    
'################################################################################################################


    ' Ensure column D is treated as numeric
    Dim lastRow As Long
    lastRow = wsLDbyDay.Cells(wsLDbyDay.Rows.Count, "D").End(xlUp).Row
    wsLDbyDay.Range("D2:D" & lastRow).NumberFormat = "General"
    wsLDbyDay.Range("D2:D" & lastRow).Value = wsLDbyDay.Range("D2:D" & lastRow).Value ' Force conversion to numbers

    ' Sort column D in "LD by Day"
    With wsLDbyDay.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsLDbyDay.Range("D2:D" & lastRow), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal
        .SetRange wsLDbyDay.Range("A1:I" & lastRow) ' Include full table
        .Header = xlYes
        .Apply
    End With

    ' Autofit columns in "LD by Day"
    wsLDbyDay.Columns("A:I").EntireColumn.AutoFit

    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub

' Function to check if a sheet exists
Function SheetExists(sheetName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Worksheets(sheetName) Is Nothing
    On Error GoTo 0
End Function

• excel
• vba
• sorting
• format
• cell

Share Improve this question Follow edited yesterday Jerry asked yesterday JerryJerry 10244 silver badges1010 bronze badges 3

• 1 Your numbers to be sorted need to be formatted as numbers not text – Tim Williams Commented yesterday
• Format as number with no decimal and result is : LD 999 999 1 1 1 1 14 14 15 15 15 15 18 18 18 2 20 3 3 3 3 3 3 3 3 32 32 32 32 32 32 – Jerry Commented yesterday
• 1 In the file you shared the values in column D all have the "number stored as text" flag. – Tim Williams Commented yesterday

Add a comment  | 

1 Answer 1

Sorted by: Reset to default 1

In the file you shared the values in column D all have the "number stored as text" flag. If you fix that then the sort will be correct.

For the formatting: it would be better to convert ColD on the source sheet to numeric format and fix your conditional formatting rules so you're testing for (eg) the numeric value 44 and not the string "44"

Finally fix the color copy line as shown below:

' Copy formats manually
    For Each cell In sourceRange
        Set targetCell = targetRange.Cells(cell.Row - sourceRange.Row + 1, cell.Column - sourceRange.Column + 1)
        With targetCell
            .Interior.Color = cell.DisplayFormat.Interior.Color '<<<<<<< was missing `cell`
            .Font.Color = cell.Font.Color ' Copy text color
            .Font.Bold = cell.Font.Bold ' Copy bold property
            .Borders.LineStyle = cell.Borders.LineStyle ' Copy border styles
        End With
    Next cell

本文标签： excelCopyPaste Cell Formatting AND Sort Ascending NumericallyStack Overflow