행이 VBA에서 색상을 변경하지 않음

Question

그래서 "입력"시트에서 데이터를 가져 와서 "현재"시트를 채우는 매크로가 VBA에 있습니다. 모든 것이 calibri 9이어야하고 J-M 열은 모두 녹색이어야하지만 J-M 열의 행 133은 녹색도 크기도 9가 아닙니다.이 문제를 해결하기 위해 내가 할 수있는 일이 궁금합니다.

이 현재 내가 가지고있는 코드입니다 ..

Sub Load16() 

Application.ScreenUpdating = False 

'Define Workbooks 
Dim loopCount As Integer 
Dim loopEnd As Integer 
Dim writeCol As Integer 
Dim matchRow As Integer 
Dim writeRow As Integer 
Dim writeEnd As Integer 

loopEnd = WorksheetFunction.CountA(Worksheets("Input").Range("A:A")) 
writeEnd = WorksheetFunction.CountIf(Worksheets("Input").Range("L:L"), "-1") 
loopCount = 1 
writeRow = 1 

Worksheets("Buttons").Range("F17:I17").Copy 
Worksheets("Current").Range("J2:M" & writeEnd).PasteSpecial Paste:=xlPasteAll 
Application.CutCopyMode = False 

Do While loopCount <= loopEnd 

If Worksheets("Input").Cells(loopCount, 12).Value <> "" And Worksheets("Input").Cells(loopCount, 12).Value <> 0 Then 

    Worksheets("Current").Cells(writeRow, 1).Value = Worksheets("Input").Cells(loopCount, 26).Value 

    writeCol = 2 
    Do While writeCol <= 9 
     Worksheets("Current").Cells(writeRow, writeCol).Value = Worksheets("Input").Cells(loopCount, writeCol - 1) 
     writeCol = writeCol + 1 
    Loop 

    writeCol = 14 
    Do While writeCol <= 30 
     Worksheets("Current").Cells(writeRow, writeCol).Value = Worksheets("Input").Cells(loopCount, writeCol - 5) 
     writeCol = writeCol + 1 
    Loop 

    Worksheets("Current").Cells(writeRow, 31).Value = Worksheets("Input").Cells(loopCount, 27) 
    writeRow = writeRow + 1 
    Else 
End If 

    loopCount = loopCount + 1 
Loop 

Worksheets("Current").Range("J1").Value = "Counsel" 
Worksheets("Current").Range("K1").Value = "Background" 
Worksheets("Current").Range("L1").Value = "Comments" 
Worksheets("Current").Range("M1").Value = "BM Action" 

Lookup Data for K - M and a few other things 
loopCount = 2 
Do While loopCount <= loopEnd 

matchRow = 0 
On Error Resume Next 
matchRow = WorksheetFunction.Match(Worksheets("Current").Cells(loopCount, 1).Value, _ 
    Worksheets("Old").Range("A:A"), 0) 
If matchRow = 0 Then 
    Else 
     Worksheets("Current").Cells(loopCount, 11).Value = Worksheets("Old").Cells(matchRow, 11).Value 
     Worksheets("Current").Cells(loopCount, 12).Value = Worksheets("Old").Cells(matchRow, 12).Value 
     Worksheets("Current").Cells(loopCount, 13).Value = Worksheets("Old").Cells(matchRow, 13).Value 
End If 

Worksheets("Current").Cells(loopCount, 10).Value =  Worksheets("Current").Cells(loopCount, 18).Value 

loopCount = loopCount + 1 
Loop 

Sheets("Current").Range("A2:AE" & loopEnd).Sort Key1:=Sheets("Current").Range("H2"), _ 
Order1:=xlAscending, Header:=xlNo 

Worksheets("Current").Columns("A:BZ").AutoFit 

Application.ScreenUpdating = True 

Worksheets("Buttons").Select 

MsgBox loopEnd - 1 & " Rows processed. " & writeEnd & " Rows remain." 

End Sub 

Answer 1

당신은 그들에 (붙여 넣기 데이터 서식을 무시하지 않습니다 수동으로, 당신이 그들이 원하는 형식으로 그 세포를 설정해야) 또는 아래 코드와 같습니다 :

Range("J133:M133").Select 
With Selection.Font 
    .Name = "Calibri" 
    .Size = 9 
    .Strikethrough = False 
    .Superscript = False 
    .Subscript = False 
    .OutlineFont = False 
    .Shadow = False 
    .Underline = xlUnderlineStyleNone 
    .ThemeColor = xlThemeColorLight1 
    .TintAndShade = 0 
    .ThemeFont = xlThemeFontMinor 
End With 
With Selection.Interior 
    .Pattern = xlNone 
    .TintAndShade = 0 
    .PatternTintAndShade = 0 
End With