Option
Explicit
Sub
TransposeData()
Dim
wshData
As
Worksheet
Dim
wshTrans
As
Worksheet
Dim
lngRowTr
As
Long
Dim
rngCp
As
Range, rngCpTimes
As
Range
Dim
rng
As
Range, rnglast
As
Range
Set
wshData = Worksheets(1)
Set
wshTrans = Worksheets(2)
lngRowTr = 1
Application.ScreenUpdating =
False
For
Each
rng
In
wshData.UsedRange.Rows
If
IsNumeric(rng.Cells(1, 1).Value)
And
Len(rng.Cells(1, 1).Value) > 0
Then
If
Not
rnglast
Is
Nothing
Then
If
rngCp.Cells.Count = 24
Then
RangeTranspose wshTrans, rngCp, rngCpTimes, lngRowTr
End
If
End
If
If
rngCp
Is
Nothing
Then
Set
rngCp = rng.Cells(1, 2)
If
lngRowTr = 1
Then
Set
rngCpTimes = rng.Cells(1, 1)
Else
Set
rngCp = Union(rngCp, rng.Cells(1, 2))
If
lngRowTr = 1
Then
Set
rngCpTimes = Union(rngCpTimes, rng.Cells(1, 1))
End
If
Set
rnglast = rng
End
If
Next
RangeTranspose wshTrans, rngCp, rngCpTimes, lngRowTr
If
Not
Application.CutCopyMode =
False
Then
Application.CutCopyMode =
False
End
If
Application.ScreenUpdating =
True
End
Sub
Sub
RangeTranspose(
ByRef
wshTrans
As
Worksheet,
ByRef
rngCp
As
Range,
ByRef
rngCpTimes
As
Range,
ByRef
lngRowTr
As
Long
)
If
Not
rngCp
Is
Nothing
Then
If
lngRowTr = 1
Then
rngCpTimes.Copy
wshTrans.Cells(lngRowTr, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=
False
, Transpose:=
True
End
If
rngCp.Copy
lngRowTr = lngRowTr + 1
With
wshTrans.Cells(lngRowTr, 1)
.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=
False
, Transpose:=
True
End
With
Set
rngCp =
Nothing
VBA.DoEvents
End
If
End
Sub