向指定变量路径的工作簿拷贝指定工作簿

a88330355

技术总部/汇总.xls下    修改”规则”工作表，点击”汇总”工作表按钮，运行宏将汇总.xls下”规则”工作表按照”汇总”工作表上的路径拷贝到指定的工作簿
功能基本已经实现可是现在出现    重复打开 技术.xlsx的提示  请大神优化一下 谢谢！

Sub 导入表单()
Application.ScreenUpdating = False '(关闭闪屏
    Set fso = CreateObject("scripting.filesystemobject")
    pth = Left(ThisWorkbook.Path, Len(ThisWorkbook.Path) - 4) '(工作簿所在的地址右去4个字符
    arr = ThisWorkbook.Sheets(1).UsedRange '(定义arr为Sheets(1)有效区域
   For j = 2 To UBound(arr)  '(定义j为Sheets(1)有效数列  如为3 读取第4行
        If Len(arr(j, 2)) > 0 Then  '(读取vloop数列
            str1 = pth & arr(j, 2) '(读取的全部路经
            If fso.fileexists(str1) Then '(如果文件存在
            With Workbooks.Open(str1) '(打开文件
               Set target = Workbooks.Open(str1)
               Set souce = ThisWorkbook
               Application.DisplayAlerts = False '(删除工作表不用点确定
               ActiveWorkbook.Unprotect Password:="123456"
               target.Sheets("规则").Delete
                ThisWorkbook.Sheets("规则").Copy before:=target.Sheets(1)
                target.Sheets("规则").Visible = False
                ActiveWorkbook.Protect Password:="123456", Structure:=True, Windows:=True
             target.Save
            target.Close (False)
            End With
            End If
        End If
    Next j
    '(取消公式黏贴 ThisWorkbook.Sheets(1).UsedRange = arr
      Application.ScreenUpdating = True '(打开闪屏
End Sub

a88330355

求大神解答一下！谢谢

a88330355

求大神解答一下！谢谢