|
Option Explicit
Sub
Transponera_Data()
'© 2005 Alla rättigheter XL-Dennis
Dim
wsSheet
As
Worksheet, wsNew
As
Worksheet
Dim
rnUsed
As
Range, rnID
As
Range, rnValues
As
Range
Dim
rnUnique
As
Range
Dim
vaUnique
As Variant
Dim
lnLastRow
As Long,
lnCounter
As Long
Application.ScreenUpdating =
False
Set
wsSheet = ActiveSheet
With
wsSheet
Set
rnUsed = .UsedRange
lnLastRow = .Range("A65536").End(xlUp).Row
Set
rnID = .Range("A4:A"
&
lnLastRow)
Set
rnValues = .Range("B5:B"
&
lnLastRow)
End With
'Lägger till ett nytt arbetsblad.
Set
wsNew = Worksheets.Add(Before:=wsSheet)
With
wsNew
'Skapa
en lista med unika element.
rnID.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"),
_
Unique:=True
Set
rnUnique = .Range(.Range("A2"),
.Range("A65536").End(xlUp))
End With
With
rnUnique
'Sorterar listan med unika element.
.Sort Key1:=Range("A1"),
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1
'Läser
in de unika elementen till en 1-baserad array.
vaUnique
= .Value
End With
'Loopar igenom listan med unika element, filtrerar ursprungslistan,
'kopierar, klistrar in all transponerad data till den nya listan.
For
lnCounter =
1
To
UBound(vaUnique)
rnUsed.AutoFilter Field:=1,
Criteria1:=vaUnique(lnCounter,
1)
rnValues.SpecialCells(xlCellTypeVisible).Copy
'Transponerar och klistrar in den synliga data.
rnUnique(lnCounter,
1).Offset(0,
1).PasteSpecial
Transpose:=True
Next
lnCounter
'Tar
bort autofilter.
rnUsed.AutoFilter
'Justerar kolumnbredd.
wsNew.UsedRange.Columns.AutoFit
Application.ScreenUpdating =
True
End
Sub |
