Question

我正在尝试累积单个文件夹中存在的不同工作簿中的数据。我在使用相同格式粘贴时出错。请帮助

 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

粘贴特殊格式错误

1 个答案: