Kopiera rader och skriv ut arbetsblad

Kopiera rader, utskrift av data samt ta bort arbetsbok

Här presenteras ett mer omfattande tips, vilket också innehåller flera moment.

Koden kan kopieras och klistras in direkt i en modul eller så kan du hämta koden här.

Exemplet bygger på:

En öppnad arbetsbok där det aktiva arbetsbladet har data i kolumnerna A:I.

För varje avdelning ska utskrift ske av data i ett separat arbetsblad, dvs varje avdelning skrivs ut på ett arbetsblad. Utskriften ska ske löpande.

Efter avslutad utskrift av samtliga avdelningars data ska arbetsboken stängas och tas bort från datorn.

Exemplet visar hur vi kan skapa en unik avdelningsnamnserie, som vi skapar mha Collection. Varje rads avdelningsnamn jämförs mot dessa unika avdelningsnamn och där namnen överensstämmer sker kopiering av radens data.

Sub KopieraRader_SkrivUtArbetsblad_TaBortAktivArbetsbok()
'© 2001 Alla rättigheter XL-Dennis
Dim UnikaVarden As New Collection
Dim vaData As Variant
Dim stFilnamn As String
Dim rnOmrade As Range, rnCell As Range
Dim wsUtskrift As Worksheet, wsData As Worksheet
Dim wsBok As Workbook
Dim lnNastaRad As Long
Dim i As Integer, j As Integer

'Hämtar uppgifter om den aktiva arbetsboken
Set wsBok = ActiveWorkbook
stFilnamn = wsBok.FullName

Set wsData = ActiveSheet
Set rnOmrade = wsData.Range(Range("D1"), Range("D65536").End(xlUp))

Application.ScreenUpdating = False

'Lägger till ett arbetsblad i den aktiva arbetsboken
Worksheets.Add After:=Worksheets(Worksheets.Count)

'Tilldelar det aktiva bladet - Utskriftsbladet - vissa värden
With ActiveSheet
      .Name = "Utskrift"
      .Range("A2:I2") = _
                   Array("ID", "AA", "BB", "Avdelning", "EE", "FF", "GG", "HH", "II")
      .Columns("A:I").AutoFit
End With

On Error Resume Next
'Skapar en unik avdelningsserie
For Each rnCell In rnOmrade
      UnikaVarden.Add rnCell.Value, CStr(rnCell.Value)
Next rnCell
On Error GoTo 0

i = UnikaVarden.Count

Set wsUtskrift = ActiveWorkbook.Worksheets("Utskrift")

'Jämför varje cells värde med de unika värdena för avdelning och
'kopierar över relevant data till utskriftsbladet
For j = 1 To i
      For Each rnCell In rnOmrade
            lnNastaRad = _
            Application.WorksheetFunction.CountA(wsUtskrift.Range("A:A")) + 1
            If rnCell.Value = UnikaVarden.Item(j) Then
                wsData.Range("A" & rnCell.Row & ":I" & rnCell.Row).Copy _
                                                     wsUtskrift.Range("A" & lnNastaRad)
            End If
      Next rnCell
      'Här skrivs arbetsbladet ut och töms därefter på värden.
      With wsUtskrift
              .PrintOut Copies:=1
              .Range(Range("A3"), Range("I65536").End(xlUp)).Clear
       End With
Next j

'Stänger arbetsboken utan att spara
With ActiveWorkbook
       .Saved = True
       .Close
End With

'Tar bort arbetsboken - Arbetsboken hamnar inte i papperskorgen!
Kill stFilnamn

Application.ScreenUpdating = True
End Sub