Kopier udskriftsområde til andet ark

Hvis du har begge mapper åbnet samtidig og kun har angivet udskriftsområder i de ark du vil kopierer, så er løsningen her.



Public Sub Overfør()
Dim PArea As String, Ark As String, Arknavn As String, Område As String

For Each navn In ThisWorkbook.Names
    Ark = Split(navn, "!")(0)
    Arknavn = Right(Ark, Len(Ark) - 1)
      Område = Right(navn, Len(navn) - 1)
  ThisWorkbook.Worksheets(Arknavn).Range(Område).Copy
      Workbooks("Intra").Activate
        Worksheets(Arknavn).Select
        Range("A1").Select
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
Next
End Sub

begrænser det lige til udskriftsområdet


Public Sub Overfør()
Dim PArea As Variant, Ark As String, Arknavn As String, Område As String

For Each PArea In ThisWorkbook.Names
    Ark = Split(PArea, "!")(0)
    Arknavn = Right(Ark, Len(Ark) - 1)
    Område = Right(PArea, Len(PArea) - 1)
   
      If Split(PArea.Name, "!")(1) = "Print_Area" Then
        ThisWorkbook.Worksheets(Arknavn).Range(Område).Copy
        Workbooks("Intra.xls").Activate
        Worksheets(Arknavn).Select
        Range("A1").Select
       
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
           
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
      End If
Next
End Sub

Hej Kabbak

Beklager, jeg har ikke nået at teste det endnu. Jeg går ud fra at koden skal ind i et modul i afsenderarket?

LQ

ja det er korrekt, den skal være i et modul i den mappe hvor du har udskriftsområderne.

Hvis du har angivet udskriftsområder i ark, der ikke skal overføres, skal vi til at luse dem fra i koden.

Efter en heftig omgang er det nu lykkedes at teste. Jeg får fejl "subscript out of range" i linjen

ThisWorkbook.Worksheets(Arknavn).Range(Område).Copy

HVordan kan det være?

Public Sub Overfør()
Dim PArea As Variant, Ark As String, Arknavn As String, Område As String

For Each PArea In ThisWorkbook.Names
    Ark = Split(PArea, "!")(0)
    Arknavn = Right(Ark, Len(Ark) - 1)
    Område = Right(PArea, Len(PArea) - 1)
  If InStr(1, PArea.Name, "!") > 0 Then
      If Split(PArea.Name, "!")(1) = "Print_Area" Then
        ThisWorkbook.Worksheets(Arknavn).Range(Område).Copy
        Workbooks("Intra.xls").Activate
        Worksheets(Arknavn).Select
        Range("A1").Select
       
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
           
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
      End If
      End If
Next
End Sub


Det er fordi du har andre navngivne områder, ud over udskriftsområderne, det skulle være ordnet nu.

Jeg har testet den med 1 ark, hvor der er anført udskriftsområde og 2 ark, hvor der er anført udskriftsområde på hvert ark. Udskriftsområderne har samme størrelse. Det gik godt, når det kun være det første ark, men jeg fik samme fejl, når det var 2 ark.

Jeg kan slet ikke gennemskue koden, men måske er der en lettere løsning? Jeg har ranges af forskellig størrelse på de 10 forskellige ark. Det er dem jeg har afgrænset som udskriftsområder. De skal kopieres over i det andet ark regelmæssigt. Ville det være nemmere at definere range for hvert ark, kopiere og indsætte i tilsvarende ark i ny mappe?

Det kunne være at jeg skulle øge pointene lidt mere. Kan jeg det?

prøv at teste denne

Public Sub Overfør()
Dim PArea As Variant, Ark As String, Arknavn As String, Område As String

For Each PArea In ThisWorkbook.Names
    Ark = Split(PArea, "!")(0)
    Arknavn = Right(Ark, Len(Ark) - 1)
    Område = Right(PArea, Len(PArea) - 1)
  If Right(PArea.Name, 10) = "Print_Area" Then
      If Split(PArea.Name, "!")(1) = "Print_Area" Then
        ThisWorkbook.Worksheets(Arknavn).Range(Område).Copy
        Workbooks("Intra.xls").Activate
        Worksheets(Arknavn).Select
        Range("A1").Select
       
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
           
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
      End If
      End If
Next
End Sub

lidt kortere

Public Sub Overfør()
Dim PArea As Variant, Ark As String, Arknavn As String, Område As String
For Each PArea In ThisWorkbook.Names
    Ark = Split(PArea, "!")(0)
    Arknavn = Right(Ark, Len(Ark) - 1)
    Område = Right(PArea, Len(PArea) - 1)
  If Right(PArea.Name, 10) = "Print_Area" Then
      ThisWorkbook.Worksheets(Arknavn).Range(Område).Copy
        Workbooks("Intra.xls").Activate
        Worksheets(Arknavn).Select
        Range("A1").Select
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
        Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
      End If
Next
End Sub

man får ikke altid sadlet samme dag som man rider.

Det virkede. Lægger du et svar?

et svar ;-))