Option Explicit
Sub
Transformera_Filtrera_Data()
'© 2004
Alla rättigheter XL-Dennis
Dim
wbBook
As
Workbook
Dim
wsData
As
Worksheet, wsTransposed
As
Worksheet
Dim
rnUnique
As
Range, rnStart
As
Range, rnData
As
Range
Dim
rnFilter
As
Range, rnFind
As
Range, rnSource
As
Range
Dim
vaField
As Variant
Dim
i
As Long,
j
As Long
Set
wbBook = ThisWorkbook
With
wbBook
Set
wsData = .Worksheets("Data")
Set
wsTransposed = .Worksheets("Transposed")
End With
With
wsData
Set
rnUnique = .Range(.Range("C1"),
.Range("C65536").End(xlUp))
Set
rnSource = .Range(.Range("C2"),
.Range("C65536").End(xlUp))
Set
rnFilter = .Range(.Range("A1"),
.Range("D65536").End(xlUp))
Set
rnData = .Range("A1")
End With
With
wsTransposed
Set
rnStart = .Range("A1")
End With
Application.ScreenUpdating =
False
'Först sorterar vi listan.
rnFilter.Sort Key1:=Range("C2"),
_
Order1:=xlAscending, _
Header:=xlGuess, _
Ordercustom:=1,
_
MatchCase:=True,
_
Orientation:=xlTopToBottom
'Därefter skapar vi en unik lista av fältnamn.
rnUnique.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rnUnique, _
CopyToRange:=Range("J1"),
_
Unique:=True
'Läser in den skapade unika listan av fältnamn till en array.
With
wsData
vaField = .Range(.Range("J2"),
.Range("J65536").End(xlUp))
End With
With
rnStart
.Value
=
"ID"
'Tilldelar rad 1 i målbladet den unika fältnamnslistan.
.Offset(0,
1).Resize(1,
UBound(vaField)).Value
= Application.Transpose(vaField)
'Tilldelar kolumn 1 i målbladet värden från kolumn 1 i källbladet.
.Offset(1,
0).Resize(rnUnique.Rows.Count,
1).Value
= rnUnique.Offset(1,
-2).Value
End With
'Loopar igenom den unika fältnamnslistan, anger utsökningsvillkoren och
'därefter överför selekterad data till målbladet.
For
i
=
LBound(vaField)
To
UBound(vaField)
rnData.AutoFilter Field:=3,
Criteria1:=vaField(i,
1)
Set
rnFind =
rnSource.SpecialCells(xlCellTypeVisible)
j
= rnFind.Rows.Count
rnStart.Offset(1,
i).Resize(j,
1).Value
= rnFind.Offset(0,
1).Value
Next
i
wsData.AutoFilterMode =
False
Application.ScreenUpdating =
False
MsgBox
"Klart!"
End Sub
