Custom Transpose Data

Submitted by Masaru Kaji.

This program does a customized data transposition based on the specified column:

Sub TransposeData()

Dim shOrg As Worksheet, shRes As Worksheet Dim rngStart As Range, rngPaste As Range Dim lngData As Long

Application.ScreenUpdating = False On Error Resume Next Application.DisplayAlerts = False Sheets("Result").Delete Application.DisplayAlerts = True On Error GoTo 0

On Error GoTo terminate

Set shOrg = Sheets(1) Set shRes = Sheets.Add(After:=shOrg) shRes.Name = "Result" With shOrg '--Sort

.Cells.CurrentRegion.Sort Key1:=.[B2], Order1:=1, _

Key2:=.[C2], Order2:=1, Key3:=.[E2], Order3:=1, Header:=xlYes '--Copy title

.Rows(1).Copy shRes.Rows(1) '--Set start range Set rngStart = ,[C2] Do Until IsEmpty(rngStart)

Set rngPaste = shRes.[A65536].End(xlUp).Offset(1) lngData = GetNextRange(rngStart) rngStart.Offset(, -2).Resize(, 5).Copy rngPaste

'Copy to V1 toV14

rngStart.Offset(, 2).Resize(lngData).Copy rngPaste.Offset(, 5).PasteSpecial Paste:=xlAll, _

Operation:=xlNone, SkipBlanks:=False, Transpose:=True 'Copy to V1FP to V14FP

rngStart.Offset(, 1).Resize(lngData).Copy rngPaste.Offset(, 19).PasteSpecial Paste:=xlAll, Operation:=xlNone,

SkipBlanks:=False, Transpose:=True Set rngStart = rngStart.Offset(lngData)

Loop End With

Application.GoTo shRes.[A1] shRes.Cells.Columns.AutoFit Application.ScreenUpdating = True Application.CutCopyMode = False

If MsgBox("Do you want to delete an original worksheet?", 36) = 6 Then Application.DisplayAlerts = False Sheets(1).Delete

Application.DisplayAlerts = True End If

Set rngPaste = Nothing Set rngStart = Nothing

0 0

Post a comment