Kopiera ett cellområde till ny arbetsbok

Kopiera cellområde till ny arbetsbok

I detta tips belyses hur vi relativt enkelt kan kopiera ett cellområde från en aktiv arbetsbok till en ny arbetsbok, som sparas och stängs.

Option Explicit

Sub Kopiera_Cellomrade_Ny_Arbetsbok()
'© 2002 Alla rättigheter XL-Dennis
Dim wbNyBok As Workbook
Dim rnOmradeKopiera As Range
Dim sMedd As String, sTitel As String, stSvar As String
'Att variabeln vaFilnamn deklareras som Variant
'och inte som String beror på det faktum att vi
'här använder oss av svensk version och XL skulle utvärdera
'uttrycket sFilnamn = "False" som "Falskt" varför händelsen
'"False" aldrig kan inträffa och vi skulle få en oändlighetsloop.
Dim vaFilnamn As Variant

sMedd = " existerar redan. Vill du ersätta nuvarande arbetsbok?"
sTitel = "För din information"

ForsokIgen:
'Kontroll att ett cellområde är markerat
If TypeOf Selection Is Range Then

'Öppnar dialogrutan "Spara / Spara Som"
       vaFilnamn = Application.GetSaveAsFilename(Filefilter:="Excel Arbetsbok(*.xls), *.xls")

'Om användaren klickar på Avbryt-knappen i dialogrutan
       If vaFilnamn = False Then
           MsgBox "Arbetsboken sparades ej.", vbOKOnly, sTitel
           Exit Sub
       End If

'Kontroll om arbetsboken redan existerar
      If Dir(vaFilnamn) <> "" Then
          stSvar = MsgBox("Arbetsboken " & vaFilnamn & sMedd, _
                      vbYesNoCancel + vbExclamation, sTitel)
          Select Case stSvar
                 Case vbCancel
                     stSvar = False
                     Exit Sub
                 Case vbNo
                     GoTo ForsokIgen
                 Case vbYes
          End Select
       End If

       Application.ScreenUpdating = False
'Här kopieras det markerade cellområdet, den nya arbetsboken sparas och stängs.
       Set rnOmradeKopiera = Selection
       Set wbNyBok = Workbooks.Add
       rnOmradeKopiera.Copy wbNyBok.Worksheets(1).Range("A1")
       wbNyBok.Worksheets(1).UsedRange.EntireColumn.AutoFit
       Application.DisplayAlerts = False
       With wbNyBok
                  .SaveAs Filename:=vaFilnamn
                  .Close
       End With
       Application.DisplayAlerts = True
       MsgBox "Arbetsboken sparad som: " & vaFilnamn, _
                  vbOKOnly + vbInformation, sTitel
End If

Application.ScreenUpdating = True
End Sub