Code To Copy Highlighted Row Insert & Add A, B etc On End Of Data In C

[Dazzawm]

I need a code that when I highlight a row(s) it copies and inserts the row beneath and adds A & B to the end of data in C.

In the sample below if I highlight all three rows the data in C is different in C so I will need a total of 6 rows with A & B on the end in as the result

Excel Workbook
	A	B	C	D	E	F	G
12			MZC1820 2001	data	data	data	data
13			MZC1820 3001	data	data	data	data
14			MZC1820 4001	data	data	data	data
Sheet1

Result

Excel Workbook
	A	B	C	D	E	F	G	H	I	J
12			MZC1820 2001A	data	data	data	data	data	data	data
13			MZC1820 2001B	data	data	data	data	data	data	data
14			MZC1820 3001A	data	data	data	data	data	data	data
15			MZC1820 3001B	data	data	data	data	data	data	data
16			MZC1820 4001A	data	data	data	data	data	data	data
17			MZC1820 4001B	data	data	data	data	data	data	data
Sheet1

Thanks.

 

[Dazzawm]

Thanks Mick thats brilliant. Please pm the link for your charity. Thanks to all that have contributed inc Worf, apo, John, snakehips and of course Mick.

 

[Dazzawm]

Actually Mick I have just noticed that the data in columns AC onwards are not being copied. Below should help.

Excel 2007
	A	B	C	AB	AC	AD	AE	AF	AG	AH	AI
4948	4386	1	CLCAN30D 7011	RWD	1	Test 1	2	TRUE			Front Suspension
4949	4387	1	CLCAN30D 7011	RWD	2	Test 2	2	TRUE			Front Suspension
4950	4388	1	CLCAN30D 7011	RWD	3	Test 3	2	TRUE			Rear Suspension
4951	4389	1	CLCAN30D 7011	RWD	4	Test 4	2	TRUE			Rear Suspension
Sheet1

If I highlight all these rows and choose 1 this is the result I get.

Excel 2007
	A	B	C	AB	AC	AD	AE	AF	AG	AH	AI
4948	4386	1	CLCAN30D 7011A	RWD	1	Test 1	2	TRUE			Front Suspension
4949	4386	1	CLCAN30D 7011A	RWD	1	Test 1	2	TRUE			Front Suspension
4950	4386	1	CLCAN30D 7011A	RWD	1	Test 1	2	TRUE			Front Suspension
4951	4386	1	CLCAN30D 7011A	RWD	1	Test 1	2	TRUE			Front Suspension
4952	4386	1	CLCAN30D 7011B	RWD	1	Test 1	2	TRUE			Front Suspension
4953	4386	1	CLCAN30D 7011B	RWD	1	Test 1	2	TRUE			Front Suspension
4954	4386	1	CLCAN30D 7011B	RWD	1	Test 1	2	TRUE			Front Suspension
4955	4386	1	CLCAN30D 7011B	RWD	1	Test 1	2	TRUE			Front Suspension
Sheet1

<br

I should get this result

Excel 2007
	A	B	C	AB	AC	AD	AE	AF	AG	AH	AI
4948	4386	1	CLCAN30D 7011A	RWD	1	Test 1	2	TRUE			Front Suspension
4949	4386	1	CLCAN30D 7011A	RWD	2	Test 2	2	TRUE			Front Suspension
4950	4386	1	CLCAN30D 7011A	RWD	3	Test 3	2	TRUE			Rear Suspension
4951	4386	1	CLCAN30D 7011A	RWD	4	Test 4	2	TRUE			Rear Suspension
4952	4386	1	CLCAN30D 7011B	RWD	1	Test 1	2	TRUE			Front Suspension
4953	4386	1	CLCAN30D 7011B	RWD	2	Test 2	2	TRUE			Front Suspension
4954	4386	1	CLCAN30D 7011B	RWD	3	Test 3	2	TRUE			Rear Suspension
4955	4386	1	CLCAN30D 7011B	RWD	4	Test 4	2	TRUE			Rear Suspension
Sheet1

Sorry to be a pain, but if you have gone to all this trouble it needs to right!

 

[MickG]

If column "AI" (col 35) is you last column then add the line (In Red) below as shown.
This line is at the top of the code.
You can, if you want remove the line above , it does not really matter.

Ltr = Cells("1", Columns.Count).End(xlToLeft).Column
Ltr = 35

Sorry I think I've misread your Query, ignore if not relevant !!!. I will have another look now !!! !!!!!

CharityLinK:- Donate to RNIB - RNIB

<tbody>
</tbody>

 

[Dazzawm]

Basically any rows I select have to be copied and inserted identically with A, Bs etc on the end of the data in C. Like the first example in post 32, all the cells are the same in C so when selected all other cells in the rows need to be copied identically.

Should I ignore your post 33?

 

[Dazzawm]

Donation made Mick, I know you will fix the problem above and the code will be exactly as I need. I wait in anticipation!!

 

[MickG]

Try this:-
Its a bit rough I needed to rewrite a lot of it.

[COLOR=Navy]Sub[/COLOR] MG29Mar46
[COLOR=Navy]Dim[/COLOR] n           [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Message     [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Dim[/COLOR] Title       [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Dim[/COLOR] Default     [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] MyValue     [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] Lst         [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Fst         [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Dic         [COLOR=Navy]As[/COLOR] Object
[COLOR=Navy]Dim[/COLOR] R           [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Ltr        [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
Ltr = Cells("1", Columns.Count).End(xlToLeft).Column
Fst = Selection.Row
Lst = Selection.Row + Selection.Rows.Count - 1


Message = "Enter a Number": Title = "Repeat Numbers": Default = 0
    [COLOR=Navy]On[/COLOR] [COLOR=Navy]Error[/COLOR] [COLOR=Navy]Resume[/COLOR] [COLOR=Navy]Next[/COLOR]
    MyValue = InputBox(Message, Title, Default)
       [COLOR=Navy]On[/COLOR] [COLOR=Navy]Error[/COLOR] GoTo endnow
        [COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
            Dic.CompareMode = vbTextCompare
                [COLOR=Navy]If[/COLOR] MyValue = 0 [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Exit[/COLOR] [COLOR=Navy]Sub[/COLOR]
        [COLOR=Navy]For[/COLOR] n = Lst To Fst [COLOR=Navy]Step[/COLOR] -1
            [COLOR=Navy]Set[/COLOR] R = Range("C" & n)
                [COLOR=Navy]If[/COLOR] Not Dic.Exists(R.Value) [COLOR=Navy]Then[/COLOR]
                    Dic.Add R.Value, R
                [COLOR=Navy]Else[/COLOR]
                    [COLOR=Navy]Set[/COLOR] Dic.Item(R.Value) = Union(Dic.Item(R.Value), R)
                [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]Next[/COLOR] n


[COLOR=Navy]Dim[/COLOR] k       [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Dn      [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] c       [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] cols    [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Ac      [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] Str     [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Dim[/COLOR] Ray
[COLOR=Navy]Dim[/COLOR] olet [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
cols = Array(1, 4, 6, 8, 15, 17, 34, 35, 43, 46)
Application.ScreenUpdating = False
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] Dic.keys
  Str = vbNullString
  [COLOR=Navy]For[/COLOR] Ac = 1 To MyValue
    n = IIf(Ac > 9, Ac - 9, Ac)
    Str = Str & "," & Dic.Item(k).Address
    Dic.Item(k).EntireRow.Interior.ColorIndex = cols(n)
    Dic.Item(k).EntireRow.Copy
    Dic.Item(k).EntireRow.Insert
  [COLOR=Navy]Next[/COLOR] Ac
    Dic.Item(k).EntireRow.Interior.ColorIndex = cols(n + 1)
    Str = Str & "," & Dic.Item(k).Address
    Ray = Split(Mid(Str, 2), ",")


[COLOR=Navy]For[/COLOR] Ac = 0 To UBound(Ray)
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] Range(Ray(Ac))
        [COLOR=Navy]If[/COLOR] Right(R, 1) Like "[A-Z]" And Ac > 0 [COLOR=Navy]Then[/COLOR]
           olet = Chr(Asc(Right(R, 1)) + Ac)
           R = Mid(R, 1, Len(R) - 1) & olet
        [COLOR=Navy]ElseIf[/COLOR] Not Right(R, 1) Like "[A-Z]" [COLOR=Navy]Then[/COLOR]
           R = R & Chr(Ac + 1 + 64)
        [COLOR=Navy]End[/COLOR] If
  [COLOR=Navy]Next[/COLOR] R
[COLOR=Navy]Next[/COLOR] Ac
[COLOR=Navy]Next[/COLOR] k
Application.ScreenUpdating = True
endnow:
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

 

[Dazzawm]

By jove I think he's cracked it!. Thanks for all this Mick, is there any need to rewrite it if it works ok? BTW I bunged the RNIB a fifty is that ok?

 

[MickG]

Thank you for that, I think (Hope) its working Ok, it just its layout is a bit messy, anyway only time will tell if its got any bugs !!! (fingers crossed)

 

[Dazzawm]

Thanks again for your time on this and the previous thread, until next time and your next charity!!