Dela upp lista mha autofilter

Dela upp listor mha autofilter

Här visas en teknik för att skapa ny arbetsblad och kopiera över utvald data till respektive blad mha autofilter.

Tipset visar hur vi kan använda oss av flera urvalskriterium för att styra händelsutvecklingen.

Option Explicit

Sub Dela_Upp_Autofilter()

   '© 2003 Alla rättigheter XL-Dennis

   Dim wbBook As Workbook

   Dim wsBlad As Worksheet

   Dim rnNamn As Range, rnFilter As Range, rnData As Range

   Dim vaNamn As Variant

   Dim ncNamn As New Collection

   Dim i As Long, j As Long

   Set wbBook = ThisWorkbook

   Set wsBlad = wbBook.Worksheets("Blad1")

   With wsBlad

      Set rnFilter = .Range("A1")

      Set rnNamn = .Range(.Range("A2"), .Range("A65536").End(xlUp))

      Set rnData = .Range(.Range("A2"), .Range("B65536").End(xlUp))

   End With

   vaNamn = rnNamn.Value

   'Skapar en unik lista av namn.

   For i = LBound(vaNamn) To UBound(vaNamn)

      On Error Resume Next

      ncNamn.Add vaNamn(i, 1), CStr(vaNamn(i, 1))

   Next

   Application.ScreenUpdating = False

   For j = 1 To ncNamn.Count

      'Filtrerar utifrån namn från den unika listan.

      rnFilter.AutoFilter Field:=1, Criteria1:=ncNamn(j)

      'Kopierar de synliga posterna.

      rnData.SpecialCells(xlCellTypeVisible).Copy

      wbBook.Worksheets.Add After:=wsBlad

      With ActiveSheet

         .Name = ncNamn(j)

         'Klistrar in de kopierade posterna.

         .Paste

         .Range("A1:B1").Font.Bold = True

         'Skapar delsummor i respektive arbetsblad.

         .Range("A1").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), _

               SummaryBelowData:=True

         .Columns("A:B").EntireColumn.AutoFit

      End With

      rnFilter.AutoFilter

   Next

   Application.ScreenUpdating = True

End Sub