|
怎样修改编程可以达到sheet1不发生变化,链接仍然存在,谢谢。
Sub test()
Dim arr1, arr2
Dim x, y, h As Long
On Error Resume Next
flag = False
wf = Application.GetSaveAsFilename("")
If wf = False Then Exit Sub
If Dir(wf) <> "" Then
If MsgBox("目标文件已存在,是否替换?", vbYesNo, "询问") = vbYes Then
flag = True
End If
Else
flag = True
End If
If flag Then
arr1 = Range("d1:g90")
ReDim arr2(1 To 90, 1 To 4)
For x = 1 To 90
If Len(arr1(x, 1) & arr1(x, 2) & arr1(x, 3)) > 0 Then
h = h + 1
For y = 1 To 4
arr2(h, y) = arr1(x, y)
Next
End If
Next
Cells.ClearContents
[d1].Resize(h, 4) = arr2
Range("d1:g90").Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=wf & "xls"
ActiveWorkbook.Close True
Application.DisplayAlerts = True
End If
[d1].Resize(90, 4) = arr1
MsgBox "OK"
End Sub
|
|