Kopiera data från andra arbetsböcker

Kopiera data från andra arbetsböcker

Nedan visas hur man kan kopiera data från andra arbetsböcker. En förutsättning är att man måste öppna de arbetsböcker man vill hämta data ifrån, vilket exemplet demonstrerar på ett tydligt sätt.

Exemplet visar också på två tekniker för att läsa in data till matriser (arrayer), dynamisk och statiskt samt hur man loopar igenom dessa på ett effektivt sätt.

Option Explicit
Option Base 1

Sub Kopiera_Data_Arbetsbocker()
Dim stFil As String, stSokvag As String, _
stFiltyp As String, stFilArray() As String
Dim vaDataArray As Variant
Dim wsDataRange As Worksheet
Dim i As Integer, x As Integer

'För att slippa att skärmen "fladdrar" när procedurerna körs.
Application.ScreenUpdating = False

'Hämta in sökvägen till önskad mapp från användare.
stSokvag = Application.InputBox _
("Ange sökvägen till önskad mapp (t ex c:\test\)", "Sökväg")

'Felhantering av stSökväg.
If dir(stSokvag) = "" Then
    MsgBox "Kan inte hitta " & stSokvag & "!", vbCritical
    Exit Sub
End If

'Här bestäms vilken filtyp som ska läsas in - filfiltrering

stFiltyp = "*.xls"

'Då vi inte vet på förhand antal filnamn i mappen måste arrayen
'dimensioneras om - dynamisk array, vilket sker mha "Redim".
'För att spara tidigare inlästa filnamn måste "Preserve" anges.
stFil = dir(stSokvag & stFiltyp )
Do Until stFil = ""
        i = i + 1
        ReDim Preserve stFilArray(i)
        stFilArray(i) = stFil
        stFil = dir
Loop

'Anrop av procedur för att skapa en ny arbetsbok med resultatet
Call Skapa_Ny_Arbetsbok()

'Tilldela variabeln wsDataRange värde
Set wsDataRange = Workbooks("Kunder" & " " _
                                 &Date).Sheets("Data")

'Fyller arrayen med konstanta värden - en mer generell lösning är
'att mha input-box hämta cellområdena från användare.
vaDataArray = Array("C5", "C9:C13", "C24:C28")

'1. Loopar lika många gånger som det finns filnamn för mha '"UBound".
'2. Öppnar XL-fil(x).
'3. Kopierar enbart värden, vilket sker här 3 gånger (=antal 'cellområden)
'4. Till cellreferens (x,i) i den nya arbetsboken.
'5. Stänger källarbetsbok utan att spara.
For x = 1 To UBound(stFilArray)
    Workbooks.Open (stSokvag & stFilArray(x))
        For i = 1 To 3
            Worksheets("Blad1").Range(vaDataArray(i)).Copy
            wsDataRange.Cells(x, i).PasteSpecial Paste:=xlValues
        Next i
    Workbooks(stFilArray(x)).Close Savechanges:=False
Next x

Application.ScreenUpdating = True

End Sub

Sub Skapa_Ny_Arbetsbok()
Dim wbNew As Workbook
Set wbNew = Workbooks.Add

'Skapar en ny arbetsbok med namnet "Kunder + åååå-mm-dd",
't ex "Kunder 2000-08-05". Den nya arbetsboken sparas i den
' aktiva mappen.
wbNew.SaveAs Filename:="Kunder" & " " & Date

With ActiveSheet
    .Name = "Data"
    .Activate
End With

End Sub