Just nu i M3-nätverket
Gå till innehåll

Utskrift med hjälp av makro


Looxoor

Rekommendera Poster

Först:

 

Tack för hjälpen tidigare!

 

Nu har vi fått nya krav på oss, det skall genereras separata excel-filer i exakt samma utförande

som PDF-filerna tidigare..

 

Jag försökte mig på att modifiera den tidigare modulen, med lite saker jag googlade fram, med varierande resultat.

 

Sub skapaXLS()
       'Först deklareras alla variabler
       Dim rnSheets As Range
       Dim rnSheetName As Range
       Dim myCell As Range
       Dim sNameAdress As String
       Dim fPath As String
       Dim ws As Worksheet
       Dim status As String
       Dim wbDest As Workbook
       Dim wbSource As Workbook
       sNameAdress = "I10"
       Set rnSheets = Me.Range("c12:c39")
       'Skärmuppdatering stängs av för att behålla vyn på sammanfattningssidan
       Application.ScreenUpdating = False
       'Här bestäms vilka blad som skall skrivas ut baserat på om deras namn visas här eller inte
       Set wbSource = ActiveWorkbook
       For Each myCell In rnSheets
       If myCell <> "" Then
               Set rnSheetName = myCell.Offset(0, -2)
               On Error Resume Next
               Set ws = Worksheets(rnSheetName.Text)
               On Error GoTo 0
               If ws Is Nothing Then
               MsgBox "Kan ej hitta arbetsblad med namn " & rnSheetName, vbExclamation, "Fel!"
               Else
               'Själva PDF-rutinen drar igång, statusmeddelandet tänds
               status = "Påbörjar XLS-skapande"
               Load frmStatus
               frmStatus.Label1.Caption = status
               frmStatus.Caption = "Skapar XLS"
               frmStatus.Show
               frmStatus.Repaint
               'Kollar ifall undermappen skickas finns i samma mapp som dagboken, annars skapas den
               fPath = ThisWorkbook.Path & "\skickas\XLS\"
               On Error Resume Next
               MkDir fPath
               On Error GoTo 0
               With ws
               'Här skapas en PDF per blad
               status = frmStatus.Label1.Caption
               frmStatus.Repaint
                   If .Range(sNameAdress) = "" Then
                   Dim answ As String
                   answ = InputBox("TA-plansnummer saknas för XLS-skapande av blad " & ws.Name & vbNewLine _
                   & "Ange ett nu eller tryck avbryt för att hoppa över", "Namn saknas")
                   If answ <> "" Then
                   .Range(sNameAdress) = answ
                   End If
                   End If
                   If .Range(sNameAdress) <> "" Then
               frmStatus.Label1.Caption = "Skapar XLS av " & .Range(sNameAdress)
               frmStatus.Repaint
               'ws.Range("a101:k145").Copy
               'Set wbDest = Workbooks.Add
               'Application.DisplayAlerts = False
               'wbDest.Range("a1").PasteSpecial xlPasteValues
               'Set wbDest = ActiveWorkbook

               ws.Copy
               Set wbDest = ActiveWorkbook
               wbDest.SaveAs fPath & .Range(sNameAdress)
               wbDest.Range("a101:k145").Copy
               wbDest.Range("a1:p400").Delete
               wbDest.Range("a1").PasteSpecial xlPasteValues
               wbDest.Close
               End If
               End With
               frmStatus.Hide
               Unload frmStatus
               End If
               End If
       Next myCell
       Application.ScreenUpdating = True
End Sub

 

Jag lyckades att bara spara som varje vald flik till en egen fil, problemet är att utanför utskriftområdet

finns massa saker som inte skall vara med, vilket jag försökte lösa genom att kopiera och klistra in special.

Special då det är massa formler som styr innehållet.

 

Detta funkade dock inte.

 

Idealiskt vore om det hade varit exakt samma som i pdf-skapandet, fast xlsx istället.

 

Tack på förhand!

Länk till kommentar
Dela på andra webbplatser

Du kanske borde dela upp koden i mindre stycken, blir lättare att debugga om man vet vilka delar som fungerar och vilka som inte. Helt enkelt dela upp det i mindre funktioner med sina unika uppgifter.

 

Men men, i teorin borde det du gör fungera tycker jag. Ser inte riktigt var problemet är. Kanske att bör ändar wDest-koden en aning till något i stil med

wbDest.Range("a1:p400").Copy          
wbDest.Range("a1").PasteSpecial xlPasteValues      
wbDest.Range("a1:A100").EntireRow.Delete
wbDest.Range("a145:A1000").EntireRow.Delete
wbDest.Range("L1:P1").EntireColumn.Delete
wbDest.Close

 

Dvs kopiera, klistra in, radera. I den ordningen.

Länk till kommentar
Dela på andra webbplatser

Arkiverat

Det här ämnet är nu arkiverat och är stängt för ytterligare svar.

×
×
  • Skapa nytt...