I have multiple workbooks each having the same sheet. I want to Copy the sheet's value to the master book.

I want to copy the selected range value of each Workbook to the single row of the new workbook.

Also, how can I retrieve the options button caption from the source workbook? Where Option buttons are ActiveX and linked cells.

If the options button is checked, copy the options button caption value to the destination cell.

Also I wish to add yyyy , mm,dd values in Date format (yyyy/mm/dd)

Sub test1()
    Dim Wsh As New IWshRuntimeLibrary.WshShell
    Dim result As WshExec
    Dim fileData() As String
    Dim path As String
    Dim cmd As String
    path = ThisWorkbook.path & "\Book1"
    cmd = "dir" & path & "/Test"
    Set result = Wsh.Exec("%ComSpec% /c" & cmd)
    Do While result.Status = 0
        DoEvents
    Loop
    fileData = Split(result.StdOut.ReadAll, vbCrLf)
    Dim i As Long
    i = 4
    For Each strData In fileData
        Cells(i, 2).Value = strData

        If Cells(i, 2).Value <> "" Then

            Cells(i, 3).Value = "='" & path & "\[" & strData & "]sheet1'!F1" '
            Cells(i, 4).Value = "='" & path & "\[" & strData & "]sheet1'!C4" '

        End If
        i = i   1
    Next
End Sub

CodePudding user response：

Retrieve Data From Closed Workbooks 2

Sub RetrieveDataFromClosedWorkbooks2()
    
    Const SOURCE_SUBFOLDER_NAME As String = "Book1"
    Const SOURCE_FILE_PATTERN As String = "*.xlsx"
    Const SOURCE_WORKSHEET_NAME As String = "Sheet1"
    Const SOURCE_CELL_ADDRESSES_LIST As String = "F1,C4"
    
    Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "B4"
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
    Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    Dim pSep As String: pSep = Application.PathSeparator
    Dim sFolderPath As String
    sFolderPath = dwb.Path & pSep & SOURCE_SUBFOLDER_NAME
    If Right(sFolderPath, 1) <> pSep Then sFolderPath = sFolderPath & pSep
    
    Dim sFileNames() As String
    sFileNames = FileNamesToArray(sFolderPath, SOURCE_FILE_PATTERN)
    
    If UBound(sFileNames) = -1 Then
        MsgBox "No files found.", vbExclamation
        Exit Sub
    End If
    
    Dim sAddresses() As String
    sAddresses = Split(SOURCE_CELL_ADDRESSES_LIST, ",")
    
    Dim sf As Long
    Dim sa As Long
    Dim dFormula As String
    
    For sf = 0 To UBound(sFileNames)
        dCell.Offset(sf).Value = sFileNames(sf) ' source file name
        For sa = 0 To UBound(sAddresses)
            dFormula = "='" & sFolderPath & "[" & sFileNames(sf) _
                & "]" & SOURCE_WORKSHEET_NAME & "'!" & sAddresses(sa)
            'Debug.Print dFormula
            With dCell.Offset(sf, sa   1)
                'Debug.Print .Address, sf, sFileNames(sf), sa, sAddresses(sa)
                .Formula = dFormula
                '.Value = .Value ' to keep only values
            End With
        Next sa
    Next sf

    MsgBox "Data retrieved.", vbInformation

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the names of all files of a folder in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function FileNamesToArray( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "*.*") _
As String()
    Const DirSwitches As String = "/b/a-d"
    
    Dim pSep As String: pSep = Application.PathSeparator
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    
    Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
    ExecString = "%comspec% /c Dir """ _
        & FolderPath & FilePattern & """ " & DirSwitches
    
    Dim pString As String
    pString = CreateObject("WScript.Shell").Exec(ExecString).StdOut.ReadAll
    
    If Len(pString) = 0 Then ' multiple issues: no file, invalid input(s)
        FileNamesToArray = Split("") ' ensure string array: 'LB = 0, UB = -1'
    Else
        pString = Left(pString, Len(pString) - 2) ' remove trailing 'vbCrLf'
        FileNamesToArray = Split(pString, vbCrLf)
    End If

End Function