Question

这是我正在寻找的一点定制。我的查询非常小;我将相同范围的单元格从文件夹中的excel文件复制到summary.xlsm，但是只想粘贴这些值（目前代码是从源工作簿粘贴公式）。

我可以理解这需要一些调整：

 c = 0
        Set rS = wS.Range(csSRng)
        'copy source range to current target row
        For Each Cel In rS
            Cel.Copy rT.Offset(, c) 'next column
            c = c + 1
        Next Cel

完整代码如下：

Sub copyMultFiles()
    Dim rS As Range, rT As Range, Cel As Range
    Dim wBs As Workbook 'source workbook
    Dim wS As Worksheet 'source sheet
    Dim wT As Worksheet 'target sheet
    Dim x As Long 'counter
    Dim c As Long
    Dim arrFiles() As String 'list of source files
    Dim myFile As String 'source file

    '    change these to suit requirements
    Const csMyPath As String = "C:\Users\Amit.Awasthi\Desktop\Jan_DRB\Cases\" 'source folder
    Const csMyFile As String = "*.xls" 'source search pattern
    Const csSRng As String = "$D$3,$C$20,$C$27,$C$35,$C$136,$C$163" 'source range
    Const csTRng As String = "$B$2" 'target range

    Application.ScreenUpdating = False

    '   target sheet
    Set wT = ThisWorkbook.Worksheets(1) 'change to suit
    '   clear sheet
    ' wT.Cells.Clear 'may not want this, comment out!!!

'   aquire list of files
    ReDim arrFiles(1 To 1)
    myFile = Dir$(csMyPath & csMyFile, vbNormal)
    Do While Len(myFile) > 0
        arrFiles(UBound(arrFiles)) = myFile
        ReDim Preserve arrFiles(1 To UBound(arrFiles) + 1)
        myFile = Dir$
    Loop
    ReDim Preserve arrFiles(1 To UBound(arrFiles) - 1)

    Set rT = wT.Range(csTRng)

    ' loop thru list of files
    For x = 1 To UBound(arrFiles)
        Set wBs = Workbooks.Open(csMyPath & arrFiles(x), False, True) 'open wbook
        Set wS = wBs.Worksheets("BC_EWB_RV_MOD") 'change sheet to suit

        c = 0
        Set rS = wS.Range(csSRng)
        'copy source range to current target row
        For Each Cel In rS
            Cel.Copy rT.Offset(, c) 'next column
            c = c + 1
        Next Cel

        wBs.Close False
        Set rT = rT.Offset(1) 'next row
        DoEvents
    Next x 'next book

    Erase arrFiles

    Application.ScreenUpdating = True

End Sub

Answer 1

试试这个：

    Set rS = wS.Range(csSRng)
    'copy source range to current target row
    For Each Cel In rS
        Cel.Copy
        rT.Offset(, c).PasteSpecial xlPasteValues 
        c = c + 1
    Next Cel

或只是：

    Set rS = wS.Range(csSRng)
    'copy source range to current target row
    For Each Cel In rS
        rT.Offset(, c).Value = Cel.Value
        c = c + 1
    Next Cel

VBA - 多个文件打开，复制和粘贴特殊（仅值）到新文件

1 个答案: