Importer oplysninger fra bestem faneblad i xls, til et bestemt faneblad i et andet xls

Et forslag kunne se ud som følger:

Koden køres fra et modul i "målfilen"

Navn på Kildefil skal rettes til i koden
Navne på ark skal rettes til i koden
Password på kildefil skal rettes til i koden

Koden åbner så kildefil
- kopierer alle celler i kildearket
- indsætter dem i mål-arket
- lukker kildefilen igen uden at ændre den.
- tømmer hukommelsen


Sub collect()

Dim sourceFil As String
sourceFil = "kopifra.xls"

Dim wbTarget As Workbook, wbSource As Workbook
Dim wsTarget As Worksheet, wsSource As Worksheet

Set wbTarget = ThisWorkbook
Set wsTarget = wbTarget.Sheets("Ark1")

If Not Dir(sourceFil) > "" Then ' checker om sourcefil findes
MsgBox "Fejl - " & sourceFil & " kan ikke findes"
Exit Sub
End If

Workbooks.Open Filename:=sourceFil, Password:="0000"
Set wbSource = ActiveWorkbook

Set wsSource = wbSource.Sheets("Ark1") ' navnet på arket i målfilen

wsSource.Cells.Copy

wbTarget.Activate
wsTarget.Select
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False

wbSource.Close

End Sub


mvh Kurt O-A

Det var LIGE det jeg havde brug for.
Tak for hjælpen. Sender du mig lige et "svar" så du kan få dine point.

Der skulle en mindre rettelse til.
min book gik i fejl på
Set wsTarget = wbTarget.Sheets
og på
wsTarget.Select
....
Sub collect()
'sætter kilden
Dim sourceFil As String
sourceFil = "C:\Users\kennet\Desktop\Kildemappen\Kildefilen.xls"

Dim wbTarget As Workbook, wbSource As Workbook
Dim wsTarget As Worksheet, wsSource As Worksheet
'sætter målet
Set wbTarget = ThisWorkbook
Set wsTarget = Sheets("Målarket")

'fejlchek hvis kilden ikke findes
If Not Dir(sourceFil) > "" Then
MsgBox "Fejl - " & sourceFil & " kan ikke findes"
Exit Sub
End If
'åbner kildefilen
Workbooks.Open Filename:=sourceFil
', Password:="0000" 'hvis der er password
Set wbSource = ActiveWorkbook

Set wsSource = wbSource.Sheets("Kildearket") ' navnet på arket i målfilen

wsSource.Cells.Copy
'aktiverer målkilden
wbTarget.Activate
'aktiverer arket
wsTarget.Activate
'vælger alle celler i arket
Cells.Select
'sætter ind i det aktive ark
ActiveSheet.Paste
Application.CutCopyMode = False

'lukker kilden
wbSource.Close

End Sub

Glad for at kunne hjælpe ;-)

God fornøjelse.

mvh Kurt