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]

Here is a recap from the beginning of what I need. In the first example I have a selection of rows in my file. If I select these rows I would like an input box to ask how many times I would like the row copied and inserted directly below. In this case I select 2 so the code then needs to look at whatever is in C. If it is a unique value then I need A, B & C put on the end of the data in C on the 3 rows (the existing row and the 2 copied & inserted). If the data is the same in C and I select 2 then there would be in the like second example a total of 6 rows.

Once extra rows have been copied and inserted I would like each different row a different colour.

First Example Before Code

Excel 2010

	A	B	C	D	E	F	G	H	I
2	Data	Data	FDGAL19D 6001	Data	Data	Data	Data	Data	Data

<tbody>
</tbody>

Sheet2​

First Example After Code

Excel 2010

	A	B	C	D	E	F	G	H	I
2	Data	Data	FDGAL19D 6001A	Data	Data	Data	Data	Data	Data
3	Data	Data	FDGAL19D 6001B	Data	Data	Data	Data	Data	Data
4	Data	Data	FDGAL19D 6001C	Data	Data	Data	Data	Data	Data

<tbody>
</tbody>

Sheet2​

Second Example Before Code

Excel 2010

	A	B	C	D	E	F	G	H	I
11	Data	Data	FDGAL19D 6004	Data	Data	Data	Data	Data	Data
12	Data	Data	FDGAL19D 6004	Data	Data	Data	Data	Data	Data

<tbody>
</tbody>

Sheet2​

Second Example After Code

Excel 2010

	A	B	C	D	E	F	G	H	I
11	Data	Data	FDGAL19D 6004A	Data	Data	Data	Data	Data	Data
12	Data	Data	FDGAL19D 6004A	Data	Data	Data	Data	Data	Data
13	Data	Data	FDGAL19D 6004B	Data	Data	Data	Data	Data	Data
14	Data	Data	FDGAL19D 6004B	Data	Data	Data	Data	Data	Data
15	Data	Data	FDGAL19D 6004C	Data	Data	Data	Data	Data	Data
16	Data	Data	FDGAL19D 6004C	Data	Data	Data	Data	Data	Data

<tbody>
</tbody>

Sheet2​

The third example below is an example when I have 1 row of unique data in C and more than 1 row with data the same and I select all the rows and put 2 in the input box

Third Example Before Code

Excel 2010

	A	B	C	D	E	F	G	H	I
2	Data	Data	FDGAL19D 6001	Data	Data	Data	Data	Data	Data
3	Data	Data	FDGAL19D 6004	Data	Data	Data	Data	Data	Data
4	Data	Data	FDGAL19D 6004	Data	Data	Data	Data	Data	Data

<tbody>
</tbody>

Sheet2​

Third Example After Code

Excel 2010

	A	B	C	D	E	F	G	H	I
2	Data	Data	FDGAL19D 6001A	Data	Data	Data	Data	Data	Data
3	Data	Data	FDGAL19D 6001B	Data	Data	Data	Data	Data	Data
4	Data	Data	FDGAL19D 6001C	Data	Data	Data	Data	Data	Data
5	Data	Data	FDGAL19D 6004A	Data	Data	Data	Data	Data	Data
6	Data	Data	FDGAL19D 6004A	Data	Data	Data	Data	Data	Data
7	Data	Data	FDGAL19D 6004B	Data	Data	Data	Data	Data	Data
8	Data	Data	FDGAL19D 6004B	Data	Data	Data	Data	Data	Data
9	Data	Data	FDGAL19D 6004C	Data	Data	Data	Data	Data	Data
10	Data	Data	FDGAL19D 6004C	Data	Data	Data	Data	Data	Data

<tbody>
</tbody>

Sheet2​

Obviously if I put 3 in the input box a further row would be added with D on the end of the data in C, select 4 E on the end and so on....

I hope I have explained it the best I can.

Thanks.

 

[Dazzawm]

Any help anyone please? The post above recaps everything I need.

 

[Worf]

Hi
This preliminary version deals with the first case(unique values). I must go offline now but will return Saturday with the complete solution.

Sub DirectlyBelow()
Dim src As Range, t, i%, j%, sr&, rv, chc%, rowc%, r, g, b
r = Array(222, 222, 44, 222, 11, 11)
g = Array(222, 111, 44, 22, 222, 222)
b = Array(22, 44, 222, 222, 11, 222)
Set src = Selection.EntireRow
rowc = src.Rows.Count - 1


t = InputBox("Enter Number Of Times Selected Row(s) To Be Copied.", "Number of Copies", 1)
If t = 0 Or t = "" Then Exit Sub
For i = src.Rows.Count To 1 Step -1
    For j = 0 To t - 1
        src.Rows(i).Offset(1).Insert
    Next
Next
sr = src.Rows(1).Row


For i = 0 To rowc
    chc = 65
    sr = sr + i * (t + 1)
    Cells(sr, 3).Value = Cells(sr, 3).Value & Chr(chc)
    Cells(sr, 1).EntireRow.Interior.Color = RGB(r(0), g(0), b(0))
    Cells(sr, 1).EntireRow.Copy
    For j = 1 To t
        chc = chc + 1
        Cells(sr, 1).Offset(j).EntireRow.PasteSpecial xlPasteAll
        rv = Cells(sr, 3).Offset(j).Value
        Cells(sr, 3).Offset(j).Value = Left(rv, Len(rv) - 1) & Chr(chc)
        Cells(sr, 1).Offset(j).EntireRow.Interior.Color = RGB(r(j), g(j), b(j))
    Next
Next
Application.CutCopyMode = 0


End Sub

 

[Dazzawm]

Thanks Worf, I know you need to do more to the code but it doesn't work as it should now. When it copies and inserts some of them are not directly below but lower down in the file. Also there are blank rows.

 

[Snakehips]

Dazza,

Does this help the cause?
The highlighting requires as many CF rules as you will need letters / colours.

Sub Dazzzawm3()
Dim i As Long
Dim y As Long
Dim z As Long


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
rpt = 3
Set MyRange = Selection
x = MyRange.Rows.Count
y = MyRange.Row
z = y + x - 1
For i = z To y Step -1
For c = rpt To 1 Step -1
    Cells(i, 3).Offset(1).EntireRow.Insert
    Rows(i + 1).Value = Rows(i).Value
    Cells(i, 3).Offset(1).Value = Cells(i, 3).Value & Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", c + 1, 1)
Next c
Cells(i, 3).Value = Cells(i, 3).Value & "A"
Next i


'Set MyRange = MyRange.Resize((rpt + 300) * x, 1)


    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("C3:C14") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Rows(y & ":" & y + ((rpt + 1) * x))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True


End Sub

Excel Workbook
	A	B	C	D	E	F	G	H	I
9	Data	Data	FDGAL19D 6001	6001 -1	Data	Data	Data	Data	Data
10	Data	Data	FDGAL19D 6004	6004 - 1	Data	Data	Data	Data	Data
11	Data	Data	FDGAL19D 6004	6004 - 2	Data	Data	Data	Data	Data
Sheet1

Excel Workbook
	A	B	C	D	E	F	G	H	I
9	Data	Data	FDGAL19D 6001A	6001 -1	Data	Data	Data	Data	Data
10	Data	Data	FDGAL19D 6001B	6001 -1	Data	Data	Data	Data	Data
11	Data	Data	FDGAL19D 6001C	6001 -1	Data	Data	Data	Data	Data
12	Data	Data	FDGAL19D 6001D	6001 -1	Data	Data	Data	Data	Data
13	Data	Data	FDGAL19D 6004A	6004 - 1	Data	Data	Data	Data	Data
14	Data	Data	FDGAL19D 6004A	6004 - 2	Data	Data	Data	Data	Data
15	Data	Data	FDGAL19D 6004B	6004 - 1	Data	Data	Data	Data	Data
16	Data	Data	FDGAL19D 6004B	6004 - 2	Data	Data	Data	Data	Data
17	Data	Data	FDGAL19D 6004C	6004 - 1	Data	Data	Data	Data	Data
18	Data	Data	FDGAL19D 6004C	6004 - 2	Data	Data	Data	Data	Data
19	Data	Data	FDGAL19D 6004D	6004 - 1	Data	Data	Data	Data	Data
20	Data	Data	FDGAL19D 6004D	6004 - 2	Data	Data	Data	Data	Data
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A9	1. / Formula is =RIGHT($C1,1)="D"	Abc
A9	2. / Formula is =RIGHT($C1,1)="C"	Abc
A9	3. / Formula is =RIGHT($C1,1)="B"	Abc
A9	4. / Formula is =RIGHT($C1,1)="A"	Abc

 

[Snakehips]

Dazza,

In the above I forgot about the Input Box !!

In the code 'rpt ' is set at 3 for test purposes. It is the variable rpt that would be set to the input box value.

 

[Dazzawm]

Thanks Tony. When I run it firstly I got a warning saying 'Excel cannot complete with available sources etc....', I pressed ok then a visual basic 400 error occured. Also I notice in your code there is a range of C3:C14. This is just a small sample of my file, it will be 50,000 rows by about 30 columns. Will this make a difference?

 

[MickG]

Try this:-
(on limited data first)
Select the contiguious rows wanted, run code, select number of repeats required, code should run !!!

[COLOR=Navy]Sub[/COLOR] MG28Mar28
[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
Fst = Selection.Row
Lst = Selection.Row + Selection.Rows.Count - 1
Message = "Enter a Number": Title = "Repeat Numbers": Default = 0
     MyValue = InputBox(Message, Title, Default)
        [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] Rs      [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] G       [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Aph     [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[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] num     [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]


cols = Array(1, 4, 6, 8, 15, 34, 35, 43)
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] Dic.keys
   num = 1
   [COLOR=Navy]With[/COLOR] Dic.Item(k)
        .Resize(MyValue * .Count).EntireRow.Insert Shift:=xlDown
            [COLOR=Navy]Set[/COLOR] G = .Offset(-(MyValue * .Count)).Resize((MyValue + 1) * .Count)
                G.Offset(, -2).Resize(, 9).Value = .Offset(, -2).Resize(1, 9).Value
                    c = 1: n = 0
       [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] G
            n = n + 1
            Aph = Chr(c + 64)
            Dn = Dn & Aph
            Dn.Offset(, -2).Resize(, 9).Interior.ColorIndex = cols(num)
            c = c + IIf(n Mod .Count = 0, 1, 0)
           num = IIf(c - 1 = 7, 0, c)
        [COLOR=Navy]Next[/COLOR] Dn
  [COLOR=Navy]End[/COLOR] With
[COLOR=Navy]Next[/COLOR] k


[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

 

[Dazzawm]

Thanks Mick that's very nearly it. Firstly when it copies and inserts it doesn't copy the complete row only up to about column J. Secondly I may have mentioned it earlier in the thread but when I have say 3 rows with A, B & C on the end of the data in C I may want to go back at a later date and add more rows so if I selected the row with C at the end of the data I need it to then add D, E, F etc. The way it does it now is it adds A onto the end of C so I have CA, CB etc...

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG28Mar31
[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
    
    MyValue = InputBox(Message, Title, Default)
        [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] Rs      [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] G       [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Aph     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[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] num     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oLet [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
cols = Array(1, 4, 6, 8, 15, 34, 35, 43)
Application.ScreenUpdating = False
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.keys
   num = 1
   [COLOR="Navy"]With[/COLOR] Dic.Item(k)
        .Resize(MyValue * .Count).EntireRow.Insert Shift:=xlDown
            [COLOR="Navy"]Set[/COLOR] G = .Offset(-(MyValue * .Count)).Resize((MyValue + 1) * .Count)
                G.Offset(, -2).Resize(, Ltr).Value = .Offset(, -2).Resize(1, Ltr).Value
                c = 1: n = 0
       
       [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] G
            n = n + 1
           [COLOR="Navy"]If[/COLOR] Right(Dn, 1) Like "[A-Z]" [COLOR="Navy"]Then[/COLOR]
                Aph = Chr(c + Asc(Right(Dn, 1)) - 1)
                Dn = Mid(Dn, 1, Len(Dn) - 1)
            [COLOR="Navy"]Else[/COLOR]
               Aph = Chr(c + 64)
            [COLOR="Navy"]End[/COLOR] If
            Dn = Dn & Aph
            Dn.Offset(, -2).EntireRow.Interior.ColorIndex = cols(num)
            c = c + IIf(n Mod .Count = 0, 1, 0)
            num = IIf(c - 1 = 7, 0, c)
        [COLOR="Navy"]Next[/COLOR] Dn
  [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] k
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick