Importer data fra et regneark/arbeidsbok

Denne makroen importerer data til et regnearkområde fra et regneark/arbeidsbok:

Sub ImportRangeFromWB(SourceFile As String, SourceSheet As String, _
    SourceAddress As String, PasteValuesOnly As Boolean, _
    TargetWB As String, TargetWS As String, TargetAddress As String)
' Imports the data in Workbooks(SourceFile).Worksheets(SourceSheet).Range(SourceAddress)
' to Workbooks(TargetWB).Worksheets(TargetWS).Range(TargetAddress)
' Replaces existing data in Workbooks(TargetWB).Worksheets(TargetWS) 
' without prompting for confirmation
' Example     ImportRangeFromWB "C:\FolderName\TargetWB.xls", _
        "Sheet1", "A1:E21", True, 
        ThisWorkbook.Name, "ImportSheet", "A3"

Dim SourceWB As Workbook, SourceWS As String, SourceRange As Range
Dim TargetRange As Range, A As Integer, tString As String
Dim r As Long, c As Integer
    ' validate the input data if necessary
    If Dir(SourceFile) = "" Then Exit Sub ' SourceFile doesn't exist
    Set SourceWB = Workbooks.Open(SourceFile, True, True)
    Application.StatusBar = "Reading data from " & SourceFile
    Workbooks(TargetWB).Activate
    Worksheets(TargetWS).Activate
    
    ' perform import
    Set TargetRange = Range(TargetAddress).Cells(1, 1)
    Set SourceRange = SourceWB.Worksheets(SourceSheet).Range(SourceAddress)
    For A = 1 To SourceRange.Areas.Count
        SourceRange.Areas(A).Copy
        If PasteValuesOnly Then
            TargetRange.PasteSpecial xlPasteValues
            TargetRange.PasteSpecial xlPasteFormats
        Else
            TargetRange.PasteSpecial xlPasteAll
        End If
        Application.CutCopyMode = False
        If SourceRange.Areas.Count > 1 Then
            Set TargetRange = _
                TargetRange.Offset(SourceRange.Areas(A).Rows.Count, 0)
        End If
    Next A
    
    ' clean up
    Set SourceRange = Nothing
    Set TargetRange = Nothing
    Range(TargetAddress).Cells(1, 1).Select
    SourceWB.Close False
    Set SourceWB = Nothing
    Application.StatusBar = False
End Sub

Dokumentet er sist oppdatert 1999-10-13 12:36:45 Utskriftsvennlig versjon