VBA-Reorganise data

[Jemma Atkinson]

Hi,

I need VBA to produce layout as shown below in the second screen shot

Excel Workbook
	A	B	C	D	E	F	G	H	I
5	Group	Case Ref	Custodian	Set ID	Source	Value Date	Entry Date	Age	CCY
6	DOMS	2	CITI	DOMS	AMP1	28-Jun-11	28-Jun-11	17	AUD
7	DOMS	3	CITI	DOMS	AMP1	28-Jun-11	28-Jun-11	17	AUD
8	DOMS	33	CITI	DOMS	DERIV	10-Jan-11	10-Jan-11	186	AUD
9	DOMS	40	CITI	DOMS	DERIV	13-Apr-11	13-Apr-11	93	AUD
10	DOMS	41	CITI	DOMS	DERIV	13-Apr-11	13-Apr-11	93	AUD
11	DOMS	42	CITI	DOMS	DERIV	27-Jun-11	25-Jun-11	18	AUD
12	LIFE	48	CITI	LIFE	AMP3	17-Jun-11	17-Jun-11	28	AUD
13	CITICASH	66	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
14	CITICASH	67	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
15	CITICASH	68	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
16	CITICASH	69	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
17	CITICASH	70	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
18	CITICASH	71	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
19	CITICASH	72	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
20	CITICASH	73	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
21	CITICASH	74	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
Sheet1

Excel Workbook
	A	B	C	D	E	F	G	H	I
5	Group	Case Ref	Custodian	Set ID	Source	Value Date	Entry Date	Age	CCY
6	DOMS	2	CITI	DOMS	AMP1	28-Jun-11	28-Jun-11	17	AUD
7	DOMS	3	CITI	DOMS	AMP1	28-Jun-11	28-Jun-11	17	AUD
8	DOMS	33	CITI	DOMS	DERIV	10-Jan-11	10-Jan-11	186	AUD
9	DOMS	40	CITI	DOMS	DERIV	13-Apr-11	13-Apr-11	93	AUD
10	DOMS	41	CITI	DOMS	DERIV	13-Apr-11	13-Apr-11	93	AUD
11	DOMS	42	CITI	DOMS	DERIV	27-Jun-11	25-Jun-11	18	AUD
12
13	Group	Case Ref	Custodian	Set ID	Source	Value Date	Entry Date	Age	CCY
14	LIFE	48	CITI	LIFE	AMP3	17-Jun-11	17-Jun-11	28	AUD
15
16	Group	Case Ref	Custodian	Set ID	Source	Value Date	Entry Date	Age	CCY
17	CITICASH	66	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
18	CITICASH	67	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
19	CITICASH	68	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
20	CITICASH	69	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
21	CITICASH	70	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
22	CITICASH	71	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
23	CITICASH	72	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
24	CITICASH	73	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
25	CITICASH	74	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
26
27
28
29
Sheet1

 

[taurean]

Try:

Public Sub InsertHeader()
Dim lLastRow As Long
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = lLastRow To 3 Step -1
    If Range("A" & i).Value2 <> Range("A" & i - 1).Value2 Then
        Range("A" & i).Resize(2, 9).Insert Shift:=xlDown
        Range("A1").Resize(, 9).Copy Destination:=Range("A" & i + 1)
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[AMAS]

Maybe something like this:

Option Explicit
Sub AddHeadings()
Dim r As Long
Dim lastrow As Long

lastrow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
For r = 3 To lastrow
    If Range("A" & r) <> Range("A" & r).Offset(-1, 0) Then
        Rows(r).Insert Shift:=xlDown
        Rows(r).Insert Shift:=xlDown
        Range("A" & r, "H" & r).Offset(1, 0) = Array("Group", "Case Ref", "Custodian", "Set ID", "Source", "Value Date", "Entry Date", "Age")
        Range("I" & r).Offset(1, 0) = "CCY"
    r = r + 2
    End If
    
Next r
End Sub

AMAS

 

[Jemma Atkinson]

Does your code assume header row is 5?

Maybe something like this:

Option Explicit
Sub AddHeadings()
Dim r As Long
Dim lastrow As Long

lastrow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
For r = 3 To lastrow
    If Range("A" & r) <> Range("A" & r).Offset(-1, 0) Then
        Rows(r).Insert Shift:=xlDown
        Rows(r).Insert Shift:=xlDown
        Range("A" & r, "H" & r).Offset(1, 0) = Array("Group", "Case Ref", "Custodian", "Set ID", "Source", "Value Date", "Entry Date", "Age")
        Range("I" & r).Offset(1, 0) = "CCY"
    r = r + 2
    End If
    
Next r
End Sub

AMAS

 

[taurean]

Does your code assume header row is 5?

I missed it too!

Public Sub InsertHeader()
Dim lLastRow As Long
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = lLastRow To 7 Step -1
    If Range("A" & i).Value2 <> Range("A" & i - 1).Value2 Then
        Range("A" & i).Resize(2, 9).Insert Shift:=xlDown
        Range("A5").Resize(, 9).Copy Destination:=Range("A" & i + 1)
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[Jemma Atkinson]

Great, can we make the headers bold?

I missed it too!

Public Sub InsertHeader()
Dim lLastRow As Long
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = lLastRow To 7 Step -1
    If Range("A" & i).Value2 <> Range("A" & i - 1).Value2 Then
        Range("A" & i).Resize(2, 9).Insert Shift:=xlDown
        Range("A5").Resize(, 9).Copy Destination:=Range("A" & i + 1)
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[Jemma Atkinson]

If i had formatting in COL F:G and then the macro does the splitting, how difficult would it be to get the below desired results?

Excel Workbook
	A	B	C	D	E	F	G	H	I
5	Group	Case Ref	Custodian	Set ID	Source	Value Date	Entry Date	Age	CCY
6	DOMS	2	CITI	DOMS	AMP1	28-Jun-11	28-Jun-11	17	AUD
7	DOMS	3	CITI	DOMS	AMP1	28-Jun-11	28-Jun-11	17	AUD
8	DOMS	33	CITI	DOMS	DERIV	10-Jan-11	10-Jan-11	186	AUD
9	DOMS	40	CITI	DOMS	DERIV	13-Apr-11	13-Apr-11	93	AUD
10	DOMS	41	CITI	DOMS	DERIV	13-Apr-11	13-Apr-11	93	AUD
11	DOMS	42	CITI	DOMS	DERIV	27-Jun-11	25-Jun-11	18	AUD
12
13	Group	Case Ref	Custodian	Set ID	Source	Value Date	Entry Date	Age	CCY
14	LIFE	48	CITI	LIFE	AMP3	17-Jun-11	17-Jun-11	28	AUD
15
16	Group	Case Ref	Custodian	Set ID	Source	Value Date	Entry Date	Age	CCY
17	CITICASH	66	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
18	CITICASH	67	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
19	CITICASH	68	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
20	CITICASH	69	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
21	CITICASH	70	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
22	CITICASH	71	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
23	CITICASH	72	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
24	CITICASH	73	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
25	CITICASH	74	SSTREET	DMPWSSAUD	AMP2	2-May-11	3-May-11	74	AUD
26
27
Sheet1

 

[taurean]

Great, can we make the headers bold?

Thats good, make them bold @ Row 5 and then they all will be bold. Or any formatting you like. VBA can do that as well.

I had not tried formatting (not much) with VBA before. Here is the code. I have added another sub routine so that it remains simpler for usage and doesn't get mixed up.

Option Explicit
Dim lLastRow As Long
Dim i As Integer
Dim r As Range
Public Sub InsertHeader()
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Range("A5").Resize(, 9).Font.Bold = True
For i = lLastRow To 7 Step -1
    
    If Range("A" & i).Value2 <> Range("A" & i - 1).Value2 Then
        Range("A" & i).Resize(2, 9).Insert Shift:=xlDown
        Range("A5").Resize(, 9).Copy Destination:=Range("A" & i + 1)
    End If
Next i
Call UpdateFormatting
Application.ScreenUpdating = True
End Sub
Private Sub UpdateFormatting()
Dim o As Integer
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("A5")
Do While r.Row < lLastRow
    
    With r.CurrentRegion.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    End With
    
    With r.Resize(, 9).Borders
    .LineStyle = xlContinuous
    .Weight = xlThick
    End With
        
    o = r.End(xlDown).Row - r.Row
    With r.Offset(1, 5).Resize(o, 2).Interior
    .Color = vbGreen
    End With
    
    Set r = r.End(xlDown).End(xlDown)
    
Loop
End Sub

 

[Jemma Atkinson]

Thanks this is Perfect!

 

[Jemma Atkinson]

Since i will be running this code from another worksheet, is this the correct way of using With and End With?

Public Sub InsertHeader()

Application.ScreenUpdating = False

With Sheets(1)
lLastRow = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A5").Resize(, 9).Font.Bold = True
For i = lLastRow To 7 Step -1
    
    If .Range("A" & i).Value2 <> .Range("A" & i - 1).Value2 Then
        .Range("A" & i).Resize(2, 9).Insert Shift:=xlDown
        .Range("A5").Resize(, 9).Copy Destination:=.Range("A" & i + 1)
    End If
Next i
Call UpdateFormatting
End With
Application.ScreenUpdating = True
End Sub
Private Sub UpdateFormatting()
Dim o As Integer
    
    With Sheets(1)
    lLastRow = .Range("A" & Rows.Count).End(xlUp).Row
    Set r = .Range("A5")
    Do While r.Row < lLastRow
    
    With r.CurrentRegion.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    End With
    
    With r.Resize(, 9).Borders
    .LineStyle = xlContinuous
    .Weight = xlThick
    End With
        
    o = r.End(xlDown).Row - r.Row
    With r.Offset(1, 5).Resize(o, 2).Interior
    .ColorIndex = 24
    End With
    
    Set r = r.End(xlDown).End(xlDown)
    Loop
    End With
End Sub