VBA EXCEL值或者公式拷贝方法

根据固定的文件夹结构将不同的文件内容通过拷贝值或者拷贝公式的方式拷贝到目标文件工作簿中，而不打开原来的文件，从而提高了多文件的复制的速度。而且还做到了实时更新。

Sub Change_Val()

Dim r1, r2, c1, c2, i, j, k, x, y As Integer

Dim Row1, Row2, Num1, Num2, MsgRow, ShtName, VorF, oPath, WhichsAs String

Dim diffNum, ItemName, PathArray

Dim fso As Object

On Error GoToErrHandler

Application.ScreenUpdating = False

Application.AskToUpdateLinks = False '关闭程序询问更新链接提示

Application.DisplayAlerts = False

ThisWorkbook.UpdateLinks = xlUpdateLinksAlways '更新链接

MsgRow = InputBox("V-修改单元格值,F-修改单元格公式,: ", "V01#cs(E^3:E^9)")

VorF = Mid(MsgRow, 1, 1)

Whichs = Mid(MsgRow, 2, 2)

MsgRow = Mid(MsgRow, 5, Len(MsgRow) - 4)

ShtName = Mid(MsgRow, 1, Application.WorksheetFunction.Find("(", MsgRow, 1) - 1)

Row1 = Mid(MsgRow, Application.WorksheetFunction.Find("(", MsgRow, 1) + 1, Application.WorksheetFunction.Find("^", MsgRow, 1) - Application.WorksheetFunction.Find("(", MsgRow, 1) - 1)

Num1 = Mid(MsgRow, Application.WorksheetFunction.Find("^", MsgRow, 1) + 1, Application.WorksheetFunction.Find(":", MsgRow, 1) - Application.WorksheetFunction.Find("^", MsgRow, 1) - 1)

MsgRow = Mid(MsgRow, Application.WorksheetFunction.Find(":", MsgRow, 1) + 1, Len(MsgRow) - Application.WorksheetFunction.Find("^", MsgRow, 1))

Row2 = Mid(MsgRow, 1, Application.WorksheetFunction.Find("^", MsgRow, 1) - 1)

Num2 = Mid(MsgRow, Application.WorksheetFunction.Find("^", MsgRow, 1) + 1, Application.WorksheetFunction.Find(")", MsgRow, 1) - Application.WorksheetFunction.Find("^", MsgRow, 1) - 1)

RowName = Row1 & Num1 & ":" & Row2 & Num2

r1 = Range(Row1 & ":" & Row1).Column

r2 = Range(Row2 & ":" & Row2).Column

c1 = CInt(Num1)

c2 = CInt(Num2)

If Whichs = "00" Then

diffNum = Array("01-北京-", "02-天津-")

end if

PathArray = Split(ThisWorkbook.Path, "\")

For i = 0 To UBound(diffNum) Step 1 '遍历每一个省文件夹

For j = 0 To UBound(ItemName) Step 1 '

oPath = PathArray(0) & "\" &PathArray(1) & "\" &diffNum(i) & "\" &ItemName(j)

'到一个子文件后,讲全部文件装入FilesToOpen

Set fso = CreateObject("Scripting.FileSystemObject")

Set myFolder = fso.GetFolder(oPath)

Set myFiles = myFolder.Files

'将每一个文件打开

k = 0

For Each oFileInmyFiles

Set wb = Workbooks.Open(myFolder& "\" &)

'如果是台账表,则需要写入修改的值

If ItemName(j) <> "汇总" Then

'将范围内的值装入每一个表单

For x = c1 To c2

For y = r1 To r2

If VorF = "V" Then

wb.Sheets(ShtName).Cells(x, y).Value = ThisWorkbook.Sheets(ShtName).Cells(x, y).Value