need keep the colors format in the output

Have this solutions working great
but need keep the color in  the source


I need keep the color of format as the input is (DTA sheet colors in cell)
In the OUTPUT sheet " AP "


 
aaa1111.PNG123_f_colors.xlsm
ADRIANA PACCOUNTING ASSISTANTAsked:
Who is Participating?
 
Ryan ChongCommented:
try this:

Sub test()
    Dim Sheet_dta As Worksheet, Sheet_Ap As Worksheet, ws As Worksheet
    Dim D As String, Code As String, AmPm As String
    Dim currentCell As Range
    Dim isIgnore As Boolean
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set Sheet_dta = Sheets("DTA")
    Set Sheet_Ap = Sheets("AP")
    
    startRow_t = 4
    'Get last rows
    lastRow_s = Sheet_dta.Cells(Sheet_dta.Rows.Count, "B").End(xlUp).Row
    lastRow_t = Sheet_Ap.Cells(Sheet_Ap.Rows.Count, "C").End(xlUp).Row + 2
    
    'Delete previous rows
    Sheet_Ap.Rows(startRow_t & ":" & lastRow_t).Delete
    
    With Sheet_Ap.Range("E:U")
        .HorizontalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .NumberFormat = "@"
    End With
    
    With Sheet_dta
        For i = 1 To lastRow_s
            D = .Cells(i, "B")
            Set currentCell = .Cells(i, "L")
            Code = currentCell.Value
            'Code = .Cells(i, "L")
            AmPm = .Cells(i, "M")
            
            'Header
            If isHeader(D, Code, AmPm) Then
                If isIgnore = False Then
                    If i > 1 Then startRow_t = startRow_t + 1
                    Sheet_Ap.Cells(startRow_t, "C") = D
                    isIgnore = True
                End If
            ElseIf D <> "" And AmPm <> "" Then
                'Debug.Print startRow_t & ": " & D & " : " & Code & " : " & AmPm
                
                If IsDate(D) Then
                    Select Case Weekday(DateValue(D), vbMonday)
                    Case 1:
                        If UCase(AmPm) = "AM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "E"), currentCell
                        ElseIf UCase(AmPm) = "PM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "F"), currentCell
                        End If
                    Case 2:
                        If UCase(AmPm) = "AM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "H"), currentCell
                        ElseIf UCase(AmPm) = "PM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "I"), currentCell
                        End If
                    Case 3:
                        If UCase(AmPm) = "AM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "K"), currentCell
                        ElseIf UCase(AmPm) = "PM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "L"), currentCell
                        End If
                    Case 4:
                        If UCase(AmPm) = "AM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "N"), currentCell
                        ElseIf UCase(AmPm) = "PM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "O"), currentCell
                        End If
                    Case 5:
                        If UCase(AmPm) = "AM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "Q"), currentCell
                        ElseIf UCase(AmPm) = "PM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "R"), currentCell
                        End If
                    Case 6:
                        If UCase(AmPm) = "AM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "T"), currentCell
                        ElseIf UCase(AmPm) = "PM" Then
                            setValue Sheet_Ap.Cells(startRow_t, "U"), currentCell
                        End If
                    End Select
                    isIgnore = False
                End If
            End If
        Next
    End With
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Function setValue(targetCell As Range, sourceCell As Range)
    targetCell.Value = sourceCell.Value
    targetCell.Font.Color = sourceCell.Font.Color
    targetCell.Interior.Color = sourceCell.Interior.Color
End Function

Function isHeader(D As String, Code As String, AmPm As String) As Boolean
    If D <> "" And Code = "" And AmPm = "" Then
        If Len(D) = 6 And IsNumeric(Left(D, 1)) And UCase(Mid(D, 2, 1)) = "W" And IsNumeric(Right(D, 4)) Then
            isHeader = True
        ElseIf Len(D) = 7 And IsNumeric(Left(D, 2)) And UCase(Mid(D, 3, 1)) = "W" And IsNumeric(Right(D, 4)) Then
            isHeader = True
        End If
    End If
End Function

Open in new window

123_f_colors_b.xlsm
1
 
ADRIANA PACCOUNTING ASSISTANTAuthor Commented:
Ryan Chong  Working As Needed  !! Great Job  Expert
0
 
Ryan ChongCommented:
Coool, glad that it works for you.
1
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.