Kopiere værdier fra flere regneark til et

Du er nok nødt til at præcisere alle celler, der skal kopieres.
Skal formateringen med eller er det kun værdien?

Forslag - p.t.:
Koden anbringes i en ny mappe (Samling) under ark1
Kan eksekveres med Alt+F8 - afspil "SamlingAfFiler"
===================================================

Dim sti, filSti
Dim kolA, kolB, kolC, kolD, kolE, kolF, kolG, samlRæk
Sub samlingAfFiler()
    sti = hentSti
    samlRæk = 1
   
    Application.ScreenUpdating = False
    traverserFilMappe sti + "TestMappe"            'erstattes af traverserFilmappe "C:\Sagsstyring\Igangværende sager"
   
    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
            kolA = .Range("A3")
            kolB = .Range("F8")
            kolC = .Range("H8")

Rem Celler kendes ikke p.t.
            kolD = "??"
            kolE = "??"
            kolF = "??"
            kolG = "??"

'            kolD = .Range("??")
'            kolE = .Range("??")
'            kolF = .Range("??")
'            kolG = .Range("??")
        End With
        xlsFil.Application.Quit
        Set xls = Nothing

Rem Opdater i samling
        With ActiveWorkbook
            .Sheets(1).Activate
            With ActiveSheet
                .Cells(samlRæk, 1) = kolA
                .Cells(samlRæk, 2) = kolB
                .Cells(samlRæk, 3) = kolC
                .Cells(samlRæk, 4) = kolD
                .Cells(samlRæk, 5) = kolE
                .Cells(samlRæk, 6) = kolF
                .Cells(samlRæk, 7) = kolG
            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

Til "supertekst"
Tak for din kommentar. Jeg kunne ikke få et til at fungere. Funktionen "traverserFilmappe" kunne min Office 2000/2003 ikke genkende. Jeg har muligvis misforstået anvendelse af den VBA kode du skrev.

Jeg har nu fundet de celler der skal kopieres.
For alle regneark på placeringen "C:\Sagsstyring\Igangværende sager" gælder det, at de celler skal kopieres til kolonner er som nedenstående.

C1 til kol. A
C5 til kol. B
F8 til Kol. C
D11 til Kol. D
G11 til Kol. E
D13 til kol. F
G13 til kol. G
J13 til kol. H

Det regneark de skal kopieres til hedder "Igangværende sager" og er placeret på "C:\Sagsstyring".
Der skal startes i række 4.
Hvert regneark skal have sin egen række, og der skal udfyldes rækker svarende til det antal regneark der er på placeringen der kopieres fra.
Det skal ende med en samlet liste over de specificerede værdier fra de angivne celler.

Jeg er nok ikke verdensmester i forklaringens kunst, så derfor tøv ikke med, at bede om yderligere svar eller forklaringer. Håber problemet kan afhjælpes

Koden er udviklet i Excel 2003 - hvilken fejlmelding kommer der?

Compile Error

Sub or function not defined

Jeg fik det til at virke.
Den kommer med en meddelelsesboks for hvert regneark den har fundet, der skal kvitteres for.

Skal ændringerne i xxx.xls gemmes?
ja  nej  annuller

Hvis det er muligt kunne jeg odt tænke mig den startede i række 4.
De 3 første rækker er kolonneoverskrifter.

Vedr. meddelelsesboks omtalt i tidligere kommentar
kan man i VBA skrive sig ud af de manuelle kvitteringer der skal foretages?
For hvert regneark den ovenstående vba-kode finder skal der kvitteres.
Er det muligt at man kan få vba-koden til, at starte indsættelsen af kopierede værdier i celle A4 som startcelle. Nu starter indsættelsen i celle A1.

Vender tilbage...

Rem Version 2
Dim sti, filSti
Dim kolA, kolB, kolC, kolD, kolE, kolF, kolG, kolH, samlRæk
Sub samlingAfFiler()
    sti = hentSti
    samlRæk = 4                                    'start-række i samling
   
    Application.ScreenUpdating = False
    traverserFilMappe sti + "TestMappe"            'erstattes af traverserFilmappe "C:\Sagsstyring\Igangværende sager"
   
    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
            kolA = .Range("C1")
            kolB = .Range("C5")
            kolC = .Range("F8")
            kolD = .Range("D11")
            kolE = .Range("G11")
            kolF = .Range("D13")
            kolG = .Range("G13")
            kolH = .Range("J13")
        End With
        xlsFil.Application.Quit
        Set xls = Nothing

Rem Opdater i samling
        With ActiveWorkbook
            .Sheets(1).Activate
            With ActiveSheet
                .Cells(samlRæk, 1) = kolA
                .Cells(samlRæk, 2) = kolB
                .Cells(samlRæk, 3) = kolC
                .Cells(samlRæk, 4) = kolD
                .Cells(samlRæk, 5) = kolE
                .Cells(samlRæk, 6) = kolF
                .Cells(samlRæk, 7) = kolG
                .Cells(samlRæk, 8) = kolH
            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

Er du kommet videre?

Hej Supertekst
Jeg har fået det til at virke.
Tak for hjælpen!!
Læg et svar så du kan få dine point.

Fint - selv tak - og et svar...