Make a crosscast reprot from a tabular report

M

michael beckinsale

Hi All,

Can anybody help me out with some vba code to create a crosscast
report from a tabular data report. I have a complete mental blank on
this!

This is an example of the soure tabular data:

Number Forename Surname Address Line 1 Address Line 2 County Post Code
Element Amount
1 Michael Smith 55 Heatherside Woking Surrey GU01 1XX Gross 4000
1 Michael Smith 55 Heatherside Woking Surrey GU01 1XX Ees Tax -1600
1 Michael Smith 55 Heatherside Woking Surrey GU01 1XX Ees Ni -200
1 Michael Smith 55 Heatherside Woking Surrey GU01 1XX Net Pay 2200
1 Michael Smith 55 Heatherside Woking Surrey GU01 1XX Ers Ni -320
1 Michael Smith 55 Heatherside Woking Surrey GU01 1XX PAYE 2120
2 Diana Jones 77 Acacia Avenue Guildford Surrey GU20 7YY Gross 2000
2 Diana Jones 77 Acacia Avenue Guildford Surrey GU20 7YY Ees Tax -800
2 Diana Jones 77 Acacia Avenue Guildford Surrey GU20 7YY Ees Ni -100
2 Diana Jones 77 Acacia Avenue Guildford Surrey GU20 7YY Net Pay 1100
2 Diana Jones 77 Acacia Avenue Guildford Surrey GU20 7YY Ers Ni -160
2 Diana Jones 77 Acacia Avenue Guildford Surrey GU20 7YY PAYE 1060

This is how l would like to data to be presented:

Number Forename Surname Adress Line 1 Address Line 2 County Post Code
Gross Ees Tax Ees Ni Net Pay Ers Ni PAYE
1 Michael Smith 55 Heatherside Woking Surrey GU01 1XX 4000 -1600 -200
2200 -320 2120
2 Diana Jones 77 Acacia Avenue Guildford Surrey GU20 7YY
2000 -800 -100 1100 -160 1060

Please beware of the word wrapping, each employee should be on one
row.

All fields are included in the source even if they are blanks or
zero's so that problem can be ignored.

Any help in this would be gratefully appreciated.

Kind regards

Michael
 
M

michael beckinsale

Hi All,

Ok l have got my head around this and come up with the following. I am
sure it can be refined further and any comments / code amendments are
welcomed:

Sub MakeCrosscast_FromTabular_V2()

Dim r As Long
Dim c As Long
Dim x As Long
Dim y As Long
Dim sr As Integer
Dim er As Integer
Dim TargetRow As Integer
Dim TargetColumn As Integer
Dim SourceWS As Worksheet
Dim TargetWS As Worksheet
Dim SourceStartRow As Long
Dim SourceStartColumn As Integer
Dim SourceRng As Range
Dim TargetRng As Range
Dim TransposeColumn As Integer
Dim ValueChangeColumn As Integer
Dim FixedColumns As Integer

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Enter the variable values as required:
ValueChangeColumn = 1
TransposeColumn = 9
TargetRow = 2
TargetColumn = 1
SourceStartRow = 2
SourceStartColumn = 1
FixedColumns = 7
Set TargetWS = Worksheets("MakeCrossCast")
Set SourceWS = Worksheets("SourceData_TabularFormat")

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

sr = SourceStartRow
TargetWS.Cells.ClearContents
For r = SourceStartRow To SourceWS.Cells(Rows.Count,
ValueChangeColumn).End(xlUp).Row
If SourceWS.Cells(r, ValueChangeColumn) <> SourceWS.Cells(r +
1, ValueChangeColumn) Then
er = r
y = FixedColumns + 1
For c = 1 To FixedColumns
TargetWS.Cells(TargetRow, c) = SourceWS.Cells(r, c)
Next c
For x = sr To er
TargetWS.Cells(TargetRow, y) = SourceWS.Cells(x,
TransposeColumn)
y = y + 1
Next x
sr = er + 1
TargetRow = TargetRow + 1
End If
Next r

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

End Sub
 
G

GS

Hi Michael,
Just a couple of suggestions...
Hi All,

Ok l have got my head around this and come up with the following. I am
sure it can be refined further and any comments / code amendments are
welcomed:

Sub MakeCrosscast_FromTabular_V2()
Click to expand...
'**Tag multi-character variables with TYPE prefixes**
'**Use descriptive names so code better self-documents**
Dim r As Long, c As Long, x As Long, y As Long 'counters ok as is
Dim lStartRow As Long, lEndRow As Long
Dim lTargetRow As Long, lTargetCol As Long
Dim wksSource As Worksheet, wksTarget As Worksheet
Dim lSourceStartRow As Long, lSourceEndRow As Long
' Dim lSourceStartColumn As Long '//not used anywhere
Dim rngSource As Range, rngTarget As Range
Dim lTransposeColumn As Long, lValueChangeColumn As Long
Dim iFixedColumns As Integer
Dim vCalcMode As Variant
With Application
.ScreenUpdating = False
Click to expand...
vCalcMode = .Calculation '//don't assume what it is
.Calculation = xlCalculationManual
End With


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Enter the variable values as required:
Click to expand...
lValueChangeColumn = 1: lTransposeColumn = 9
' lSourceStartRow = 2: lSourceStartColumn = 1 '//not really needed
lStartRow = 2
lSourceEndRow = _
wksSource.Cells(Rows.Count, lValueChangeColumn).End(xlUp).Row
lTargetRow = 2: lTargetColumn = 1: iFixedColumns = 7
Set wksTarget = Worksheets("MakeCrossCast")
Set wksSource = Worksheets("SourceData_TabularFormat")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Click to expand...
wksTarget.Cells.ClearContents
For r = lSourceStartRow To lSourceEndRow
If wksSource.Cells(r, lValueChangeColumn) <> _
wksSource.Cells(r + 1, lValueChangeColumn) Then
lEndRow = r: y = iFixedColumns + 1
For c = 1 To iFixedColumns
wksTarget.Cells(lTargetRow, c) = wksSource.Cells(r, c)
Next 'c
For x = lStartRow To lEndRow
wksTarget.Cells(lTargetRow, y) _
= wksSource.Cells(x, lTransposeColumn): y = y + 1
Next 'x
lStartRow = lEndRow + 1: lTargetRow = lTargetRow + 1
End If
Next 'r
 
G

GS

Just to clarify, my reply is a revision to the actual code posted. I
did not test against the sample data to determine whether or not it
actually works!
 
G

GS

This is tested...

Option Explicit

Sub MakeCrosscast_FromTabular_V2()
Dim r As Long, c As Long, x As Long, y As Long 'counters ok as is
Dim lStartRow As Long, lEndRow As Long
Dim lTargetRow As Long, lTargetCol As Long
Dim wksSource As Worksheet, wksTarget As Worksheet
Dim lSourceStartRow As Long, lSourceEndRow As Long
Dim rngSource As Range, rngTarget As Range
Dim vCalcMode As Variant, vHdrs As Variant

With Application
vCalcMode = .Calculation '//don't assume what it is
.ScreenUpdating = False: .Calculation = xlCalculationManual
End With

Set wksTarget = Worksheets("MakeCrossCast")
Set wksSource = Worksheets("SourceData_TabularFormat")

'Initialize variables
Const lTransposeColumn As Long = 9
Const lValueChangeColumn As Long = 1
Const lFixedColumns As Long = 7
Const sHdrs As String = _
"Number,Forname,Surname,Address1,Address2,County,Post Code," _
& "Gross,Ees Tax,Ees Ni,Net Pay,Ers Ni,PAYE"
vHdrs = Split(sHdrs, ",")

lStartRow = 2
lSourceEndRow = _
wksSource.Cells(Rows.Count, lValueChangeColumn).End(xlUp).Row

lTargetRow = 2: lTargetCol = 1

'CrossCast data
On Error GoTo ErrExit
With wksTarget
.Cells.ClearContents: .Range("A1").Resize(, UBound(vHdrs) + 1) =
vHdrs
End With
For r = lStartRow To lSourceEndRow
If wksSource.Cells(r, lValueChangeColumn) <> _
wksSource.Cells(r + 1, lValueChangeColumn) Then
lEndRow = r: y = lFixedColumns + 1
For c = 1 To lFixedColumns
wksTarget.Cells(lTargetRow, c) = wksSource.Cells(r, c)
Next 'c
For x = lStartRow To lEndRow
wksTarget.Cells(lTargetRow, y) _
= wksSource.Cells(x, lTransposeColumn): y = y + 1
Next 'x
lStartRow = lEndRow + 1: lTargetRow = lTargetRow + 1
End If
Next 'r

ErrExit:
With Application
.ScreenUpdating = True: .Calculation = vCalcMode
End With
End Sub
 
M

michael beckinsale

Hi Garry,

Many thanks for the feedback.

As you probably noted l wrote the code in a generic way so that it is
re-usable, hence the the targetcolumn, targetrow variables.

I quite like the amendment to insert the headers descriptions and will
enhance so that the array is filled automatically.

Once again thanks for the response.

Regards

Michael
 
G

GS

michael beckinsale was thinking very hard :
Hi Garry,

Many thanks for the feedback.

As you probably noted l wrote the code in a generic way so that it is
re-usable, hence the the targetcolumn, targetrow variables.

I quite like the amendment to insert the headers descriptions and will
enhance so that the array is filled automatically.

Once again thanks for the response.

Regards

Michael
Click to expand...

You're welcome! Best wishes...
 
Top