[已解决]跨文件引用的宏，运行中要点击确定,如何避免？

arter_2006

宏为跨文件引用，要引用几百甚至上千的数据，每引用一个文件一个单元格的数据，就要点击“确定“按钮，如何在执行宏的过程中，如果有提示框跳出是否以只读模式打开，自动点击“确定“。如何实现？非常感谢。
注明，因为上层的要求，被引用文件的只读属性不能改。


非常感谢指教。

最佳答案

月排行榜 / 总排行榜

七彩屋

2016-1-10 09:25

Sub 名称()
    Dim arr, brr(), i
    arr = Range("A2:A" & [A666].End(3).Row)
    For i = 1 To UBound(arr)
       Application.ScreenUpdating = False
         Set wb = Workbooks.Open(ActiveWorkbook.Path & "\" & arr(i, 1) & ".xlsm", , True)
           ReDim Preserve brr(1 To UBound(arr), 1 To 1)
             brr(i, 1) = wb.Sheets("Sheet1").Range("B2")
          wb.Close False
        Application.ScreenUpdating = True
    Next
    Range("B2").Resize(UBound(brr), 1) = brr
End Sub

跳转到最佳答案楼层

砂海

        Set wb = Workbooks.Open(ActiveWorkbook.Path & "\" & arr(i, 1) & ".xlsm", , True)
就可以了,下面的结构避免闪屏
==========================
     Application.ScreenUpdating = True
Set wb = Workbooks.Open(文件名, , True)
wb.Windows(1).Visible = False

    wb.Windows(1).Visible = True
    wb.Close True
    Application.ScreenUpdating = True

arter_2006

非常感谢您的指教，
本人宏是个菜鸟；
我改成了：

Sub 名称()
    Dim arr, brr(), i
    arr = Range("A2:A" & [A666].End(3).Row)
    For i = 1 To UBound(arr)
        Set wb = GetObject(ActiveWorkbook.Path & "\" & arr(i, 1) & ".xlsm")
        ReDim Preserve brr(1 To UBound(arr), 1 To 1)
        brr(i, 1) = wb.Sheets("Sheet1").Range("B2")
        wb.Close False
    Next
    Range("B2").Resize(UBound(brr), 1) = brr

         Application.ScreenUpdating = True
  Set wb = Workbooks.Open(ActiveWorkbook.Path & "\" & arr(i, 1) & ".xlsm", , True)
wb.Windows(1).Visible = False

    wb.Windows(1).Visible = True
    wb.Close True
    Application.ScreenUpdating = True
End Sub

、能否请您把上面的宏改下，或把附件改下，非常感谢您。

七彩屋

Sub 名称()
    Dim arr, brr(), i
    arr = Range("A2:A" & [A666].End(3).Row)
    For i = 1 To UBound(arr)
       Application.ScreenUpdating = False
         Set wb = Workbooks.Open(ActiveWorkbook.Path & "\" & arr(i, 1) & ".xlsm", , True)
           ReDim Preserve brr(1 To UBound(arr), 1 To 1)
             brr(i, 1) = wb.Sheets("Sheet1").Range("B2")
          wb.Close False
        Application.ScreenUpdating = True
    Next
    Range("B2").Resize(UBound(brr), 1) = brr
End Sub

arter_2006

可惜只有一分了，否则的多加些，非常感谢各位。