Link til mange regneark

Jeg forestiller mig eksempelvis, at alle filer lå i samme "Folder" hvorefter et script kan løbe samtlige regneark igennem og give ovenstående.  Filnavngivningen er desværre ikke lige så simpel som angivet i eksemplet.

Kan godt lade sig gøre via VBA!
Skal oprindelsen (filnavne) ikke med - eller?

Rem Version 1 - henter cellen A1 fra alle filer / Ark1
Rem ==================================================
Dim sti, filSti
Dim celleA1, samlRæk
Sub samlingAfFiler()
    sti = hentSti
    samlRæk = 1
   
    Application.ScreenUpdating = False
    traverserFilMappe sti + "TestMappe"            'erstattes af dit navn
   
    ActiveWorkbook.Sheets(1).Activate
    ActiveSheet.Columns.AutoFit
   
    Application.ScreenUpdating = True
   
    MsgBox ("Samling er udført")
End Sub
Private Function hentSti()
    hentSti = ActiveWorkbook.Path
    If Right(hentSti, 1) <> "\" Then
        hentSti = hentSti + "\"
    End If
End Function
Private Sub traverserFilMappe(mappe)
Dim xlsFil
Dim fs, f, fil, fc
On Error GoTo fejl
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappe)
    Set fc = f.Files

Rem behandling af alle filer i mappe
    For Each fil In fc
        Set xlsFil = CreateObject("Excel.Application")
        With xlsFil
            .Workbooks.Open mappe + "\" + fil.Name
            .Sheets(1).Activate
            celleA1 = .Range("A1")                  '<--- hent cellen  i fil
        End With
        xlsFil.Application.Quit
        Set xls = Nothing

Rem Opdater i samling
        With ActiveWorkbook
            .Sheets(1).Activate
            With ActiveSheet
                .Cells(samlRæk, 1) = celleA1        '<--- indsæt cellen i samling
            End With
            samlRæk = samlRæk + 1
        End With
    Next
    Exit Sub

fejl:
    xlsFil.Application.Quit
    Set xls = Nothing
    MsgBox ("Fejl erkendt - kontakt udvikler")
End Sub

ublic Sub Opdater()
    Dim Sti As String, Fil() As Variant, Nr As Integer, I As Integer
    With Application.FileDialog(msoFileDialogFolderPicker) ' Folder vælger
        .Show
        Sti = .SelectedItems(1) ' hvad du valgte
    End With
Nr = 0
ReDim Preserve Fil(Nr)
Fil(Nr) = Dir(Sti & "\*.xls")  ' Retrieve the first entry.
Do While Fil(Nr) <> ""    ' Start the loop.
Nr = Nr + 1
ReDim Preserve Fil(Nr)

    Fil(Nr) = Dir    ' Get next entry.
Loop
Nr = Nr - 1
For I = 0 To Nr
Cells(I + 2, 1).FormulaLocal = "='" & Sti & "\[" & Fil(I) & "]Ark1'!$A$2" ' indsætter formel i A kolonnen, startende i A2
Cells(I + 2, 2) = Sti & "\[" & Fil(I) ' skrver i B kolonnen hvad mappen hedder og hvor den ligger
Next
End Sub

der manglede lige det første bogstav

Public Sub Opdater()
    Dim Sti As String, Fil() As Variant, Nr As Integer, I As Integer
    With Application.FileDialog(msoFileDialogFolderPicker) ' Folder vælger
        .Show
        Sti = .SelectedItems(1) ' hvad du valgte
    End With
Nr = 0
ReDim Preserve Fil(Nr)
Fil(Nr) = Dir(Sti & "\*.xls")  ' Retrieve the first entry.
Do While Fil(Nr) <> ""    ' Start the loop.
Nr = Nr + 1
ReDim Preserve Fil(Nr)

    Fil(Nr) = Dir    ' Get next entry.
Loop
Nr = Nr - 1
For I = 0 To Nr
Cells(I + 2, 1).FormulaLocal = "='" & Sti & "\[" & Fil(I) & "]Ark1'!$A$2" ' indsætter formel i A kolonnen, startende i A2
Cells(I + 2, 2) = Sti & "\[" & Fil(I) ' skrver i B kolonnen hvad mappen hedder og hvor den ligger
Next
End Sub

Til kabbak

Det virker. Lav svar og pointene er dine.

et svar ;-))