Åbne flere regneark

Tales vi om ark i en Excel-projektmappe - eller er der tale om flere Excel-projektmapper i en Windows-mappe

Det er flere Excel-projektmapper i en windows-mappe!!

det kan gøres med funktionen LOPSLAG

Det vil gøre regnearket for tungt at arbejde med. Jeg er interesseret i en VBA kode der kan løse det.

hvad hedder det ark, hvor du skal hente celle A1 og A2 fra ?

Dette her er mit svar - skal nok justeres lidt, når de nøjagtige informationer kendes - måske du selv kan gennemskue den ?

Public Sub GetDataFromOtherWorkbook()
    Dim sFolder As String
    Dim sFileToOpen() As String
    Dim wbData As Workbook
    Dim rInsert As Range
    Dim lCount As Long

    Application.ScreenUpdating = False
    Set rInsert = Sheets("Ark1").Range("A1")
    sFolder = "D:\VBA-Test\"
   
    lCount = 1
    ReDim sFileToOpen(1 To lCount)
    sFileToOpen(lCount) = Dir(sFolder + "*.xls")
    Do While Not (sFileToOpen = "")
        lCount = lCount + 1
        ReDim Preserve sFileToOpen(1 To lCount)
        sFileToOpen(lCount) = Dir
    Loop
   
    For lCount = 1 To UBound(sFileToOpen)
        Set wbData = Application.Workbooks.Open(Filename:=sFileToOpen(lCount))
        rInsert.Offset(lCount, 0).Value = wbData.Sheets("Ark1").Range("A1").Value
        rInsert.Offset(lCount, 1).Value = wbData.Sheets("Ark1").Range("A2").Value
        wbData.Close SaveChanges:=False
        Set wbData = Nothing
    Next lCount
   
    ' Clean up
    Set rInsert = Nothing
    Application.ScreenUpdating = True
End Sub

Her er også en.
Den åbner dog ikke filerne, men henter bare værdierneSub BatchProcess()
Dim FS As FileSearch
Dim FilePath As String, FileSpec As String
Dim i As Integer
Dim v As Variant
Dim sheet As String, cell_1 As String, cell_2 As String
FilePath = "C:\dokumenter\"
FileSpec = "*.xls"
sheet = "Ark1"
cell_1 = "$A$1"
cell_2 = "$A$2"
Set FS = Application.FileSearch
With FS
  .LookIn = FilePath
  .Filename = FileSpec
  .Execute
  If .FoundFiles.Count = 0 Then
      MsgBox ("Ingen filer fundet")
      Exit Sub
  End If
End With
For i = 1 To FS.FoundFiles.Count
  v = Split(FS.FoundFiles(i), Application.PathSeparator)
  ActiveCell.Offset(i - 1, 0) = hentceller(FilePath, v(UBound(v)), sheet, cell_1)
  ActiveCell.Offset(i - 1, 1) = hentceller(FilePath, v(UBound(v)), sheet, cell_2)
Next
  Range(ActiveCell, ActiveCell.Offset(i, 1)) = Range(ActiveCell, ActiveCell.Offset(i, 1)).Value
End Sub

Function hentceller(p, f, s, c)
hentceller = "='" & p & "[" & f & "]" & s & "'!" & Range(c).Address(, , xlA1)
End Function

Så har jeg prøvet mig frem med begge to. FlemmingDahl din kommer ikke videre fra denne linie Do While Not (sFileToOpen = "").
Bak, din virker perfekt, jeg kunne bare godt tænke mig at den kun henter værdien og ikke laver en kæde. Jeg har selv prøvet men kan ikke lige få det til at hænge sammen. Kan du hjælpe?

Linien
Range(ActiveCell, ActiveCell.Offset(i, 1)) = Range(ActiveCell, ActiveCell.Offset(i, 1)).Value
skulle gerne gøre at at kæderne forsvinder igen, idet den kopier cellerne og derefter kun indsætter værdierne.
Der findes dog en anden metode, men den har jeg ikke rigtig fået til at virke endnu...

Okey, så lykkedes det alligevel. Denne henter fra lukkede filer uden kæderne

Skift funktionen hentceller ud med denne her og slet linien
Range(ActiveCell, ActiveCell.Offset(i, 1)) = Range(ActiveCell, ActiveCell.Offset(i, 1)).Value


Private Function hentceller(path, file, sheet, range_ref)
Dim arg As String
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
      Range(range_ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function

UPS, en lille fejlskriv.

Private Function hentceller(path, file, sheet, range_ref)
Dim arg As String
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
      Range(range_ref).Range("A1").Address(, , xlR1C1)
hentceller = ExecuteExcel4Macro(arg)
End Function

Lidt omskevet og lidt bedre version.

Sub GetValuesFromClosedFiles()
Dim FS As FileSearch
Dim FilePath As String
Dim i As Integer, j As Integer
Dim v As Variant
Dim Cells2Get()
Const Filespec = "*.xls"              'udfyldes af bruger Filtype
Const sheet = "Sheet1"                'udfyldes af bruger Arknavn

FilePath = "C:\test\"                'udfyldes af bruger Startfolder
Cells2Get = Array("A1", "B1", "C1")  'udfyldes af bruger Celler, der skal hentes
Application.ScreenUpdating = False
Set FS = Application.FileSearch
With FS
  .LookIn = FilePath
  .Filename = Filespec
  '.SearchSubFolders = True          'skal underfoldere også søges
  .Execute
  If .FoundFiles.Count = 0 Then
      MsgBox ("Ingen filer fundet")
      Exit Sub
  End If
  For i = 1 To .FoundFiles.Count
    v = Split(.FoundFiles(i), Application.PathSeparator)
    FilePath = Left(.FoundFiles(i), InStrRev(.FoundFiles(i), Application.PathSeparator))
    ActiveCell.Offset(i - 1, 0) = FilePath & v(UBound(v))
    For j = 0 To UBound(Cells2Get)
      ActiveCell.Offset(i - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))
    Next
  Next
End With
Application.ScreenUpdating = False
End Sub

Private Function GetValue(path, file, sheet, range_ref)
Dim arg As String
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(range_ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function

Jeg har delt pointene imellem jer, for jeg har brugt lidt fra hver og sat det sammen til en løsning, som jeg umiddelbart er tilfreds med. Tak for hjælpen

Til dit brug skal du lige fjerne linien
ActiveCell.Offset(i - 1, 0) = FilePath & v(UBound(v))

og fjerne 1-tallet efter j i linien
ActiveCell.Offset(i - 1, j + 1) = _
                  GetValue(FilePath, v(UBound(v)), sheet, Cells2Get(j))

Jeg vil da oz lige vise en version der virker - har rettet den bette fejl.

Public Sub GetDataFromOtherWorkbook()
    Dim sFolder As String
    Dim sFileToOpen() As String
    Dim wbData As Workbook
    Dim rInsert As Range
    Dim lCount As Long

    Application.ScreenUpdating = False
    Set rInsert = Sheets("Ark1").Range("A1")
    sFolder = "D:\VBA-Test\"
   
    lCount = 1
    ReDim sFileToOpen(1 To lCount)
    sFileToOpen(lCount) = Dir(sFolder + "*.xls")
    Do While Not (sFileToOpen(lCount) = "")
        lCount = lCount + 1
        ReDim Preserve sFileToOpen(1 To lCount)
        sFileToOpen(lCount) = Dir
    Loop
    ReDim Preserve sFileToOpen(1 To lCount - 1)
    For lCount = 1 To UBound(sFileToOpen)
        Set wbData = Application.Workbooks.Open(Filename:=sFolder & sFileToOpen(lCount))
        rInsert.Offset(lCount, 0).Value = wbData.Sheets(1).Range("A1").Value
        rInsert.Offset(lCount, 1).Value = wbData.Sheets(1).Range("A2").Value
        wbData.Close SaveChanges:=False
        Set wbData = Nothing
    Next lCount
   
    ' Clean up
    Set rInsert = Nothing
    Application.ScreenUpdating = True
End Sub

>>Flemmingdahl,
Det er lige det jeg står og mangler.
Bortset fra at jeg gerne vil hente en range, f.exs a5:k5, og at det ark jeg vil hente fra hedder noget med mellemrum. (har forsøgt - men kunne ikke få det til at virke).

Hvis du er interesseret i at hjælpe kan jeg oprette et nyt spørgsmål.

mvh
Peter