Kopier data fra flere arbeidsbøker

Makroen nedenfor kan benyttes til å kopiere et celleområde fra ett enkelt regneark eller alle regnearkene i en eller flere arbeidsbøker.
Eksempelet nedenfor må tilpasses litt for å passe til ditt behov.

Sub TestCopyDataFromMultipleWorkbooks()
Dim varWorkbooks As Variant, wb As Workbook
    varWorkbooks = "Excel Workbooks (*.xl*),*.xl*,All Files (*.*),*.*"
    varWorkbooks = Application.GetOpenFilename(varWorkbooks, 1, _
        "Velg en eller flere arbeidsbøker å kopiere data fra (Ctrl+A merker alle filer i mappen)", , True)
    If Not IsArray(varWorkbooks) Then Exit Sub ' ingen filer er valgt
    
    With Application
        .ScreenUpdating = False
        .Cursor = xlWait
    End With
    
    Set wb = Workbooks.Add ' opprett en ny arbeidsbok
    
    ' linjene nedenfor må tilpasses hver kopieringsoppgave
    ' kopier fra et navngitt regneark:
    CopyDataFromMultipleWorkbooks wb.Worksheets(1), varWorkbooks, "Ark1", "A1:D10" 
    ' kopier data fra det første regnearket:
    'CopyDataFromMultipleWorkbooks wb.Worksheets(1), varWorkbooks, 1, "A1:D10" 
    ' kopier data fra ale regnearkene:
    'CopyDataFromMultipleWorkbooks wb.Worksheets(1), varWorkbooks, vbNullString, "A1:D10" 
    
    wb.Activate
    Set wb = Nothing
    
    With Application
        .Cursor = xlDefault
        .StatusBar = False
        .ScreenUpdating = True
    End With
End Sub

Sub CopyDataFromMultipleWorkbooks(wsTarget As Worksheet, varWorkbooks As Variant, _
    varWorksheet As Variant, strWorksheetRange As String)
Dim r As Long, i As Long, wb As Workbook, ws As Worksheet, rng As Range
    If wsTarget Is Nothing Then Exit Sub
    If Not IsArray(varWorkbooks) Then Exit Sub
    
    For i = LBound(varWorkbooks) To UBound(varWorkbooks)
        On Error Resume Next
        Set wb = Workbooks.Add(varWorkbooks(i)) ' prøver å åpne en kopi av arbeidsboken
        On Error GoTo 0
        If Not wb Is Nothing Then
            With wb
                Application.StatusBar = "Kopierer fra " & varWorkbooks(i) & "..."
                If Len(varWorksheet) = 0 Then ' kopier fra alle regnearkene
                    For Each ws In .Worksheets
                        With wsTarget ' finn en ledig rad 
                            r = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                        End With
                        On Error Resume Next
                        Set rng = ws.Range(strWorksheetRange)
                        If Not rng Is Nothing Then
                            rng.Copy wsTarget.Range("A" & r) ' kopier data til rapportarket
                            Set rng = Nothing
                        End If
                        On Error GoTo 0
                    Next ws
                    Set ws = Nothing
                Else ' copy from one worksheet
                    On Error Resume Next
                    Set ws = wb.Worksheets(varWorksheet)
                    On Error GoTo 0
                    If Not ws Is Nothing Then
                        With wsTarget ' finn en ledig rad
                            r = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                        End With
                        On Error Resume Next
                        Set rng = ws.Range(strWorksheetRange)
                        If Not rng Is Nothing Then
                            rng.Copy wsTarget.Range("A" & r) ' kopier data til rapportarket
                            Set rng = Nothing
                        End If
                        On Error GoTo 0
                        Set ws = Nothing
                    End If
                End If
                .Close False ' lukk arbeidsboken uten å lagre endringer
                Application.StatusBar = False
            End With
            Set wb = Nothing
        End If
    Next i ' neste arbeidsbok
End Sub

Dokumentet er sist oppdatert 2008-04-30 22:33:25 Utskriftsvennlig versjon