Question

我正在尝试在Excel VBE中组合/嵌套3个不同的函数：打开，循环和单击。我把它们单独写出来，但不确定如何将它们组合起来。我已经尝试了“调用宏”函数但是返回了一个编译错误。

目标是打开某个文件夹中的一堆文件并单击所有文件夹中的URL（URL并不总是相同，所以我需要一个针对工作表中任何未知URL的点击功能）

打开宏：

Sub openMyfile()

Dim Source As String
Dim StrFile As String

Source = "/users/kmogilevsky/Desktop/IC_new/"
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")

Do While Len(StrFile) > 0
    Workbooks.Open Filename:=Source & StrFile
    StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Loop
End Sub

循环宏：

 Sub LoopThroughFiles()
   Dim MyObj As Object, MySource As Object, file As Variant
   Set MySource = MyObj.GetFolder("/users/kmogilevsky/Desktop/IC_new/")
   For Each file In MySource.Files
      If InStr(file.Name, "test") > 0 Then
           End If
   Next file
 End Sub


    Click macro (this needs some work):

    Private Sub CommandButton1_Click()
    Call NewSub
    End Sub

Answer 1

Sub ReadWorkbooksInCurrentFolder()
    Dim wbDst As Workbook
    Dim wbSrc As Workbook
    Dim MyPath As String
    Dim strFilename As String

    'Stop annoying popups while macro is running
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    'When working with many open workbooks its good to explicitly reference all workbooks, makes sure your code works and easier to read, understand and remember which workbook is which.
    Set wbDst = ThisWorkbook

    srcSheetName = "Data"
    dstSheetName = "Results"

    'I want to loop through all .xlsx files in the folder
    MyPath = ThisWorkbook.Path
    strFilename = Dir(MyPath & "\*.xlsx", vbNormal)

    If Len(strFilename) = 0 Then
        MsgBox "No workbooks found ending in .xlsx in current folder"
        Exit Sub
    End If

    Do Until strFilename = ""

        Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
        Call CollectData(wbDst, wbSrc, dstSheetName, srcSheetName)
        wbSrc.Close

        strFilename = Dir()

    Loop


    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

Sub CollectData(ByRef wbDst as Workbook, ByRef wbSrc as Workbook, dstSheetName as String, srcSheetName as String)

    'Copy cell A1 contents in source workbook to destination workbook cell A1
    wbDst.Sheets(dstSheetName).Range("A1") = wbSrc.Sheets(srcSheetName).Range("A1")

End Sub

请编辑子程序CollectData（）以使其符合您的需要，即执行click / url打开。（我不熟悉从excel打开网址，但我经常浏览工作簿）

Answer 2

此代码将打开桌面上IC_New文件夹中的所有Excel文件然后，它将查看每个工作表并按照工作表上的任何超链接进行操作。

Sub Open_ClickHyperlinks()

    Dim sPath As String
    Dim vFiles As Variant
    Dim vFile As Variant
    Dim wrkBk As Workbook
    Dim wrkSht As Worksheet
    Dim HLink As Hyperlink

    sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & _
        "IC_New" & Application.PathSeparator

    'Return all files that have an extension starting with xls.
    vFiles = EnumerateFiles(sPath, "xls*")

    'Loop through each file.
    For Each vFile In vFiles
        'Open the file
        Set wrkBk = Workbooks.Open(Filename:=vFile, UpdateLinks:=False)
        With wrkBk
            'Loop through each worksheet in the file.
            For Each wrkSht In .Worksheets
                'Loop through each hyperlink on the worksheet.
                For Each HLink In wrkSht.Hyperlinks
                    HLink.Follow
                Next HLink
            Next wrkSht
            .Close SaveChanges:=False
        End With
    Next vFile

End Sub

'Get all files in the specified folder, default to include all subfolders as well.
Public Function EnumerateFiles(sDirectory As String, _
            Optional sFileSpec As String = "*", _
            Optional InclSubFolders As Boolean = True) As Variant

    EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
        ("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
        IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")

End Function

在Excel中组合宏

2 个答案: