粘貼特殊格式錯誤

Question

我試圖從存在於單一的folder.I不同的工作簿accumualate數據，同時粘貼具有相同formats.Pls幫助

Sub VaR() 
Const FOLDER As String = "C:\Sushant_Files\" 
Const cStrWSName As String = "VaR" 

On Error GoTo ErrorHandler 

Dim i As Integer 
Dim fileName As String 
' Cleaning VaR columns E to J' 
ThisWorkbook.Worksheets(cStrWSName).Range("C8:J11").ClearContents 
' Cleaning the Annexure' 
ThisWorkbook.Worksheets(cStrWSName).Range("L5:Q200").UnMerge 
ThisWorkbook.Worksheets(cStrWSName).Range("L5:Q200").ClearFormats 
ThisWorkbook.Worksheets(cStrWSName).Range("L5:Q200").ClearContents 


ThisWorkbook.Worksheets(cStrWSName).Range("M5").Value = "X" 

Dim rowno As Integer 
rowno = 7 
fileName = Dir(FOLDER, vbDirectory) 
Do While Len(fileName) > 0 

    If Right$(fileName, 4) = "xlsx" Or Right$(fileName, 3) = "xls" Then 
    i = i + 1 
    Dim currentWkbk As Excel.Workbook 
    Set currentWkbk = Excel.Workbooks.Open(FOLDER & fileName) 

    ' For loop for adding values to cells' 
    For j = 8 To 11 
    ThisWorkbook.Worksheets(cStrWSName).Cells(j, 3).Value = ThisWorkbook.Worksheets (cStrWSName).Cells(j, 3).Value + currentWkbk.Sheets(cStrWSName).Cells(j, 3).Value 
    ThisWorkbook.Worksheets(cStrWSName).Cells(j, 4).Value = ThisWorkbook.Worksheets(cStrWSName).Cells(j, 4).Value + currentWkbk.Sheets(cStrWSName).Cells(j, 4).Value 
    ThisWorkbook.Worksheets(cStrWSName).Cells(j, 5).Value = ThisWorkbook.Worksheets(cStrWSName).Cells(j, 5).Value + currentWkbk.Sheets(cStrWSName).Cells(j, 5).Value 
    Next 

    'Adding to the Annexure' 
    rowNum = Range("M65536").End(xlUp).Row 

    ThisWorkbook.Worksheets(cStrWSName).Cells(rowno, 12).Value = Left(currentWkbk.Name, Len(currentWkbk.Name) - 4) 
    ThisWorkbook.Worksheets(cStrWSName).Cells(rowno + 1, 12).Font.Bold = True 
    currentWkbk.Sheets(cStrWSName).Range("F7:J11").Copy 
    ThisWorkbook.Worksheets(cStrWSName).Range(Cells(rowno, 13), Cells(rowno + 4, 17)).PasteSpecial xlPasteValues 
    *ThisWorkbook.Worksheets(cStrWSName).Range(Cells(rowno, 13), Cells(rowno + 4, 17)).PasteSpecial xlPasteFormats(I got an error here)* 
    rowno = rowno + 6 
    currentWkbk.Close 
    End If 
    fileName = Dir 
    Application.CutCopyMode = False 
Loop 
'Building the Annexure' 
ThisWorkbook.Worksheets(cStrWSName).Range("M5").Value = "" 
ThisWorkbook.Worksheets(cStrWSName).Range("L5").Value = "Annexure I" 
ThisWorkbook.Worksheets(cStrWSName).Range("L5:Q5").Merge 
ThisWorkbook.Worksheets(cStrWSName).Range("L5:Q5").HorizontalAlignment = xlCenter 
ThisWorkbook.Worksheets(cStrWSName).Range("L5:Q5").Font.Bold = True 

ProgramExit: 
    Exit Sub 
ErrorHandler: 
    MsgBox Err.Number & " - " & Err.Description 
    Resume ProgramExit 
End Sub 

Answer 1

它爲我得到了一個錯誤。試試這兩個變化。更換

currentWkbk.Sheets(cStrWSName).Range("F7:J11").Copy 
ThisWorkbook.Worksheets(cStrWSName).Range(Cells(rowno, 13), _ 
Cells(rowno + 4, 17)).PasteSpecial xlPasteValues 
ThisWorkbook.Worksheets(cStrWSName).Range(Cells(rowno, 13), _ 
Cells(rowno + 4, 17)).PasteSpecial xlPasteFormats 

與

currentWkbk.Sheets(cStrWSName).Range("F7:J11").Copy 

With ThisWorkbook.Worksheets(cStrWSName) 
    .Range(.Cells(rowno, 13), .Cells(rowno + 4, 17)).PasteSpecial xlPasteValues 

    DoEvents 

    .Range(.Cells(rowno, 13), .Cells(rowno + 4, 17)).PasteSpecial xlPasteFormats 
End With 

OR

currentWkbk.Sheets(cStrWSName).Range("F7:J11").Copy 

With ThisWorkbook.Worksheets(cStrWSName) 
    .Range(.Cells(rowno, 13), .Cells(rowno + 4, 17)).PasteSpecial xlPasteValues 

    currentWkbk.Sheets(cStrWSName).Range("F7:J11").Copy 

    .Range(.Cells(rowno, 13), .Cells(rowno + 4, 17)).PasteSpecial xlPasteFormats 
End With