+ Reply to Thread
Results 1 to 2 of 2

link all workbooks to a index page

  1. #1
    Rich
    Guest

    link all workbooks to a index page

    i have approx 100 workbooks in a folder which contain data on individual staff

    i would like to be able to have a "index" page which reads all the
    information from all the other workbooks in rows

    in the data workbooks the info is always in the same place,

    is this possible in vba

  2. #2
    Forum Contributor
    Join Date
    12-12-2005
    Posts
    667

    Excel files

    I have adapted some code from others (sorry I did not note their names):
    Option Explicit
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, _
    ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" _
    (lpBrowseInfo As BROWSEINFO) As Long
    Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
    End Type
    Private FSO As Object
    Private c As Long
    Private ar

    Sub Folders()
    Dim i As Long
    Dim sFolder As String
    Dim sh As Worksheet
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ar = Array()
    c = -1
    sFolder = GetFolder
    ReDim ar(1, 0)
    If sFolder <> "" Then
    SelectFiles sFolder
    On Error Resume Next
    Set sh = Worksheets("Files")
    On Error GoTo 0
    If Not sh Is Nothing Then
    sh.Cells.ClearContents
    Else
    Worksheets.Add.Name = "Files"
    End If
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Path"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Excel Files"
    Range("A1:B1").Select
    Selection.Font.Bold = True
    With ActiveSheet
    For i = LBound(ar, 2) To UBound(ar, 2)
    Cells(i + 2, 1) = ar(0, i)
    Cells(i + 2, 2) = ar(1, i)
    Next
    .Columns("A:B").EntireColumn.AutoFit
    End With
    End If
    End Sub

    Sub SelectFiles(Optional Pth As String)
    Dim fldr As Object
    Dim Folder As Object
    Dim file As Object
    Dim Files As Object
    If Pth = "" Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Pth = GetFolder
    End If
    Set Folder = FSO.GetFolder(Pth)
    Set Files = Folder.Files
    For Each file In Files
    If Right(file.Name, 3) = "xls" Then
    c = c + 1
    ReDim Preserve ar(1, c)
    ar(0, c) = Folder.path & "\"
    ar(1, c) = file.Name
    End If
    Next file
    For Each fldr In Folder.Subfolders
    SelectFiles fldr.path
    Next
    End Sub

    Function GetFolder(Optional ByVal Name As String = _
    "Select a folder.") As String
    Dim BI As BROWSEINFO
    Dim path As String
    Dim oDialog As Long
    BI.pidlRoot = 0&
    BI.lpszTitle = Name
    BI.ulFlags = &H1
    oDialog = SHBrowseForFolder(BI)
    path = Space$(512)
    GetFolder = ""
    If SHGetPathFromIDList(ByVal oDialog, ByVal path) Then
    GetFolder = Left(path, InStr(path, Chr$(0)) - 1)
    End If
    End Function
    Best regards,

    Ray

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1