Excel VBA-打开多个文件,将特殊(仅值)复制并粘贴到新文件
这是一个有点定制我正在寻找。我有很小的疑问;我正在将相同范围的单元格从文件夹中的excel文件复制到summary.xlsm,但只希望粘贴值(当前代码正在粘贴源工作簿中的公式) 我可以理解这里需要一些调整:Excel VBA-打开多个文件,将特殊(仅值)复制并粘贴到新文件,excel,vba,Excel,Vba,这是一个有点定制我正在寻找。我有很小的疑问;我正在将相同范围的单元格从文件夹中的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.Offse
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
试试这个:
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