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

 

[mikerickson]

Perhaps

Sub test()
    Dim headerRange As Range
    Dim insertCell As Range
    Dim searchTerm As String
    
    Set headerRange = Sheet1.Range("A5:I5")
    Set insertCell = headerRange.Cells(2, 1)
    
    Application.CutCopyMode = False
    searchTerm = CStr(insertCell.Value)
    
    With headerRange.Cells(1, 1).EntireColumn
    
        Do Until searchTerm = vbNullString
                With .Cells(Application.Match(searchTerm, .Cells, 0), 1).Resize(Application.CountIf(.Cells, searchTerm), 1)
                    If Application.CutCopyMode = xlCopy Then
                        .Resize(1, headerRange.Columns.Count).Insert shift:=xlDown
                    End If
                    Set insertCell = .Cells(.Rows.Count + 1, 1)
                    searchTerm = CStr(insertCell.Value)
                    headerRange.Copy
                End With
        Loop
        
    End With
End Sub

 

[Jemma Atkinson]

The code did not insert two row gap between each data set. How would the code be changed to look like #7

Perhaps

Sub test()
    Dim headerRange As Range
    Dim insertCell As Range
    Dim searchTerm As String
    
    Set headerRange = Sheet1.Range("A5:I5")
    Set insertCell = headerRange.Cells(2, 1)
    
    Application.CutCopyMode = False
    searchTerm = CStr(insertCell.Value)
    
    With headerRange.Cells(1, 1).EntireColumn
    
        Do Until searchTerm = vbNullString
                With .Cells(Application.Match(searchTerm, .Cells, 0), 1).Resize(Application.CountIf(.Cells, searchTerm), 1)
                    If Application.CutCopyMode = xlCopy Then
                        .Resize(1, headerRange.Columns.Count).Insert shift:=xlDown
                    End If
                    Set insertCell = .Cells(.Rows.Count + 1, 1)
                    searchTerm = CStr(insertCell.Value)
                    headerRange.Copy
                End With
        Loop
        
    End With
End Sub

 

[mikerickson]

Sub test()
    Dim headerRange As Range
    Dim insertCell As Range
    Dim searchTerm As String
    
    Set headerRange = Sheet1.Range("A5:I5")
    Set insertCell = headerRange.Cells(2, 1)
    
    Application.CutCopyMode = False
    searchTerm = CStr(insertCell.Value)
    
    With headerRange.Cells(1, 1).EntireColumn
    
        Do Until searchTerm = vbNullString
                With .Cells(Application.Match(searchTerm, .Cells, 0), 1).Resize(Application.CountIf(.Cells, searchTerm), 1)
                    If Application.CutCopyMode = xlCopy Then
                        .Resize(1, headerRange.Columns.Count).Insert
                        [COLOR="Red"].Offset(-1, 0).Resize(1, headerRange.Columns.Count).Insert[/COLOR]
                    End If
                    Set insertCell = .Cells(.Rows.Count + 1, 1)
                    searchTerm = CStr(insertCell.Value)
                    headerRange.Copy
                End With
        Loop
        
    End With
End Sub