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?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ryan ChongBusiness Systems Analyst , ex-Senior Application EngineerCommented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
ADRIANA PACCOUNTING ASSISTANTAuthor Commented:
Ryan Chong  Working As Needed  !! Great Job  Expert
0
Ryan ChongBusiness Systems Analyst , ex-Senior Application EngineerCommented:
Coool, glad that it works for you.
1
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.