Macro to cut header and paste on row

[sncb]

Hi All,

I currently I have data pasted in my excel sheet as below in a tab called 'codes' something like this:

Excel Workbook
	A	B	C	D
1	DEUTSCHLAND	*	*	*
2	Warehouse	Code	Date	Item ID
3	WH-5142	ABB	14/3/11	M4600
4	WH-5142	ABB	14/3/11	M4600
5	WH-5142	MNC	14/3/11	G6500
6	WH-5142	MNC	14/3/11	G6500
7	WH-5142	MNC	14/3/11	G6500
8	WH-5142	RGV	14/3/11	R5566
9	WH-5142	RGV	14/3/11	R5566
10	FRANCE	*	*	*
11	Warehouse	Code	Date	Item ID
12	WH-9197	ABB	14/3/11	M4600
13	WH-9197	ABB	14/3/11	M4600
14	WH-9197	MNC	14/3/11	G6500
15	WH-9197	MNC	14/3/11	G6500
16	WH-9197	MNC	14/3/11	G6500
17	WH-9197	RGV	14/3/11	R5566
18	WH-9197	RGV	14/3/11	R5566
codes

and many more countries under DE and FR and would like to change it to look like this below in tab called 'changed':

Excel Workbook
	A	B	C	D	E
1	*	Warehouse	Code	Date	Item ID
2	DEUTSCHLAND	WH-5142	ABB	14/3/11	M4600
3	DEUTSCHLAND	WH-5142	ABB	14/3/11	M4600
4	DEUTSCHLAND	WH-5142	MNC	14/3/11	G6500
5	DEUTSCHLAND	WH-5142	MNC	14/3/11	G6500
6	DEUTSCHLAND	WH-5142	MNC	14/3/11	G6500
7	DEUTSCHLAND	WH-5142	RGV	14/3/11	R5566
8	DEUTSCHLAND	WH-5142	RGV	14/3/11	R5566
9	*	*	*	*	*
10	*	Warehouse	Code	Date	Item ID
11	FRANCE	WH-9197	ABB	14/3/11	M4600
12	FRANCE	WH-9197	ABB	14/3/11	M4600
13	FRANCE	WH-9197	MNC	14/3/11	G6500
14	FRANCE	WH-9197	MNC	14/3/11	G6500
15	FRANCE	WH-9197	MNC	14/3/11	G6500
16	FRANCE	WH-9197	RGV	14/3/11	R5566
17	FRANCE	WH-9197	RGV	14/3/11	R5566
changed

Could anyone recommend the macro?

Thanks

 

[Arcticwarrio]

are they ALL in that format?

 

[sncb]

Hi,

Thanks for replying. No they are all different countries.

B regards

 

[Weaver]

are the * to denote empty cells or do they actually have '*' in them?

 

[sncb]

No..There are no stars...assume them absent..

Thanks for replying

BRegards

 

[sncb]

Hi ArticW and Weaver,

Please ignore the above request sicne Ive found a way to solve the issue at the source itself. Im getting the data from a report and have decided to change the report so that the data can be received just the way I want.

So thanks for looking into it and didn't want to waste your time in case u'all are still looking.

Have a nice day.

B Regards

 

[Arcticwarrio]

LOL i've just done it too:

Sub change_code()
    Dim ws1 As Worksheet, ws2 As Worksheet, NextRow As Long, NextRow2 As Long, x As Integer
    Dim code1 As String, codeA As String, codeB As String, codeC As String, codeD As String
    Set ws1 = Sheets("codes")
    Set ws2 = Sheets("changed")
    With ws2.Range("A1:E1")
            .ColumnWidth = Array(20, 20, 8, 12, 10)
    End With
    With ws2.Range("C1:E1")
            .EntireColumn.HorizontalAlignment = xlCenter
    End With
    ws1.Select
    ws1.Range("A1").Select
    code1 = Selection.Value

    NextRow = ws2.Range("A65536").End(xlUp).Row
    NextRow1 = ws1.Range("A65536").End(xlUp).Row + 1

    With ws1.Range("A:A")
        For x = 2 To NextRow1 Step 1
            With .Cells(x, 1)
            If .Value = "" Then GoTo ENDME
            ws2.Range("A" & NextRow).Value = code1
            ws2.Range("B" & NextRow).Value = ws1.Range("A" & x).Value
            ws2.Range("C" & NextRow).Value = ws1.Range("B" & x).Value
            ws2.Range("D" & NextRow).Value = ws1.Range("C" & x).Value
            ws2.Range("E" & NextRow).Value = ws1.Range("D" & x).Value
            NextRow = ws2.Range("A65536").End(xlUp).Row + 1
            If ws1.Range("A" & x).Offset(2, 0).Value = "Warehouse" Then
            code1 = ws1.Range("A" & x).Offset(1, 0).Value
            x = x + 1
             GoTo SNEXT
            End If
            End With
SNEXT:
        Next x
    End With
ENDME:
End Sub

arctic

 

[Weaver]

Hi ArticW and Weaver,

Please ignore the above request sicne Ive found a way to solve the issue at the source itself. Im getting the data from a report and have decided to change the report so that the data can be received just the way I want.

So thanks for looking into it and didn't want to waste your time in case u'all are still looking.

Have a nice day.

B Regards

Lol I was going to have a crack at this during my lunch break!

Glad you got it sorted - it's usually best if you can fix the issue at source in any case.

W

 

[Weaver]

I did it anyway, cos I was bored.

Sub sncb()
    Dim ttl, lr, f
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    Columns(1).Insert shift:=xlToRight
    For i = 1 To lr
    If WorksheetFunction.CountA(Cells(i, 2).Resize(, 4)) = 1 Then
        ttl = Cells(i, 2)
        f = False
    Else
        If f Then
            Cells(i, 1) = ttl
        Else
            f = True
        End If
    End If
    Next i
    On Error Resume Next
    Columns(3).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns(1).AutoFit
End Sub

 

[sncb]

Thanks both again for your help. The macro worked and Im sure I can use it somewhere else where I cannot change the design of the report.

Once again, Thanks for your time and Cheers!!