[Løst] Excel 2007 VBA Lagre som ny arbeidsbok

[Bigelk]

Hei.

 

Jeg har en arbeidsbok med 10 ark

 

Jeg lurer på hvordan jeg lagrer 7 av disse arkene i en ny arbeidsbok.

 

Jeg har en kode til og Lagre 1 ark som ny arbeidsbok, men klarer ikke og gjøre om denne koden så den lagrer 7 ark i steden.

 

Har prøvd litt.

On Error GoTo ErrHandler
   Dim wb As Workbook
   Dim wbN As String
   Dim filepath As String
   Dim Pn As String
   Dim New_Topp3 As String
   Dim New_Topp10 As String
   Dim New_Total As String
   Dim New_MenyUltra As String
   Dim New_SparJoker As String
   Dim New_Kiwi As String
   Dim New_Assosierte As String

   Pn = Sheets("Topp 3").Range("A2").Value
   Application.ScreenUpdating = False

   New_Topp3 = "Topp 3"
   New_Topp10 = "Topp 10"
   New_Total = "Total"
   New_MenyUltra = "Meny Ultra"
   New_SparJoker = "Spar Joker"
   New_Kiwi = "Kiwi"
   New_Assosierte = Assossierte

'***Her skjønner jeg ikke helt åssen jeg skal få inn alle de nye arkene***
   Sheets(4).Copy
   Set wb = ActiveWorkbook
   wb.Sheets(1).Name = New_Topp3

   'Navn på my arbeidsbok
   wbN = Pn

   filepath = "\\filserver\tope\test\"
   wb.SaveAs filepath & wbN
   wb.Close 'Lukk
ErrHandler:
   If Err.Number = 1004 Then
    MsgBox "Dokumentet Kan ikke lagres fordi det har blitt bruk tegn som er ugyldige, vennligst bruk bare bokstaver og tall i Produktnavnene"
   End If

 

Hilsen

 

Torbjørn

[Harald Staff]

Hei Torbjørn

 

Flytte fire navngitte ark til nytt dokument:

 

Sheets(Array("Leif", "Tone", "Anne", "Line")).Move

 

HTH. Beste hilsen Harald

[Bigelk]

Hei

Takk for svar harald.

 

Jeg fant nettopp en kode som jeg gjorde om litt på,

som også fungerer

 

Application.ScreenUpdating = False
   Dim OutlookApp As Object
   Dim MItem As Object
   Dim Wb As Workbook
   Dim NewWb As Workbook
   Dim Pn As String
   Dim FilePath As String

   Pn = Sheets("Topp 3").Range("A2").Value
   FilePath = "\\filserver\tope\test\"


   Set Wb = ActiveWorkbook

   Wb.Sheets(4).Copy
   Set NewWb = ActiveWorkbook
    Wb.Sheets(5).Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count)
    Wb.Sheets(6).Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count)
    Wb.Sheets(7).Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count)
    Wb.Sheets(8).Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count)
    Wb.Sheets(9).Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count)
    Wb.Sheets(10).Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count)
   NewWb.SaveAs FilePath & Pn
   NewWb.Close
   Application.ScreenUpdating = True

 

Hilsen

 

Torbjørn