Kopier et ark fra mange projektmapper

Jeg kører denne macro som nogenlunde gør det første du ønsker

Det den gør er

1. vælg overordnet mappe struktur hvor du har dine delresultater
2. søger efter delresultater.xls i de udvalgte mapper
3. hver gang den finder en tager den sheet status og kopier
4. sætter det ind i master.xls og omdøber det til mappenavnet for den mappe den har fundet det i.
5. lukker delresultater.xls og søger videre i mappe strukturen.

Sub SrchForFiles()
        Dim i As Long, z As Long, Rw As Long
    Dim ws As Worksheet
    Dim y As Variant
    Dim fLdr As String, fil As String, FPath As String
    Dim MyTempList As Variant
    Dim lfldrnm As Integer
    Dim FldrName As String
    Dim FilName As String
    Dim sTmp As String
    Dim t As Long
   
   
    y = "delresultat.xls"
    Application.ScreenUpdating = False
    '**********************************************************************
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        fLdr = .SelectedItems(1)
    End With
    '**********************************************************************
    With Application.FileSearch
        .NewSearch
        .LookIn = fLdr
        .SearchSubFolders = True
        .Filename = y
     
      On Error GoTo 0
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                fil = .FoundFiles(i)
                    'Get file path from file name
                FPath = Left(fil, Len(fil) - Len(Split(fil, "\")(UBound(Split(fil, "\")))) - 1)
                Workbooks.Open Filename:=fil
                Sheets("Status").Select
                    MyTempList = Split(fil, "\")
                        For t = 0 To UBound(MyTempList)
                        Next t
                    FldrName = MyTempList(UBound(MyTempList) - 1)
                Sheets("Status").Copy After:=Workbooks("Master.xls").Sheets(1)
                ActiveSheet.Name = FldrName
                Windows("delresultat.xls").Close (True)
                                     
                'FPath = Left(fil, Len(fil) - Len(Split(fil, "\")(UBound(Split(fil, "\")))) - 1)
               
            Next i
        End If
    End With
   
     
    Exit Sub

End Sub

Jeg kan godt høre/se den gøre meget af det jeg ønsker.

Har nogle spørgsmål:
y = "delresultat.xls" - Det vil betyde jeg skal lave en mappe til hvert delresultat. Kan de ikke ligge i samme mappe med forskellige navne X.xls - Y.xls osv.

Hvordan får jeg så makroen til at summe D2 i alle de nye faner i fanen STATUS?

Håber du kan hjælpe mig!

Så skal vi ud i en lidt anden opbygnign.. er selv ikke den mest rutineret i vba. men prøv at søg på nettet .. der er rigtigt meget hjælp og så kan du strikke det sammen..

Hvor kan du foreslå?

her hentes ark og kolonne D summeres, derefter kommer resultatet over i arket Status kolonne D.

Public Sub HentArk()
    Dim Fil As String, Sti As String, Total(19000), I As Integer
    Sti = "\data" ' Ret til din sti
    Application.ScreenUpdating = False
    Fil = Dir(Sti & "\*.xls")
    Do While Fil <> ""
        Workbooks.Open Filename:= _
                      Sti & "\" & Fil
                        Sheets("1").Name = Split(Fil, ".")(0)
        Sheets(Split(Fil, ".")(0)).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
     
    For I = 0 To 19000
    Total(I) = Total(I) + Cells(I + 2, "D")
    Next
 
        Windows(Fil).Close False
        Fil = Dir
    Loop
    Sheets("Status").Range("D2:D19001") = WorksheetFunction.Transpose(Total)
    Application.ScreenUpdating = True
End Sub

Tak Kabbak!