Insert x rows into x-1 space, Row Grouping Issue & Code Speed

[skull_eagle]

Hi All,

I have the following code

[face=Courier New]Selection.Cut

Sheets.Add After:=ActiveSheet
Range("A1").Select
    ActiveSheet.Paste

MyArray = Array("Format")
Application.DisplayAlerts = [color=darkblue]False[/color]

    [color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] Worksheets
        [color=darkblue]For[/color] i = 0 [color=darkblue]To[/color] [color=darkblue]UBound[/color](MyArray)
            [color=darkblue]If[/color] ws.Name = MyArray(i) [color=darkblue]Then[/color]
                ws.Delete
                [color=darkblue]Exit[/color] [color=darkblue]For[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] i
    [color=darkblue]Next[/color] ws

Application.DisplayAlerts = [color=darkblue]False[/color]

ActiveSheet.Name = "Format"

Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=R[1]C"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = _
    "=IF((MIN(R[1]C:R[10]C))=(MAX(R[1]C:R[10]C)), (MIN(R[1]C:R[10]C)), (MIN(R[1]C:R[10]C)) & "" - "" & (MAX(R[1]C:R[10]C)))"
    Range("C2").Select
    Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 9)), TrailingMinusNumbers:=[color=darkblue]True[/color]
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Multiple Boxes Listed"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Multiple Files Listed"
    Range("F1").Select
    ActiveCell.Value = "2011"
  


lastCol = ActiveSheet.Range("a1").End(xlToRight).Column
    LastRow = ActiveSheet.Cells(1048576, lastCol).End(xlUp).Row
ActiveSheet.Range("a1", ActiveSheet.Cells(LastRow, lastCol)).Select
Selection.Copy

ActiveSheet.Previous.Select

Selection.Insert Shift:=xlDown
ActiveSheet.Paste

[color=darkblue]With[/color] Selection
.Resize(.Rows.Count - 1).Offset(1, 0).Select
[color=darkblue]End[/color] [color=darkblue]With[/color]


Selection.Rows.Group
Selection.Rows.Group
    
ActiveSheet.Outline.ShowLevels RowLevels:=1

[A:A].SpecialCells(xlBlanks).EntireRow.Delete

Sheets("Format").Delete[/face]

I know it is not a thing of beauty and I apologies for that.

Overview:
I work my way through a master worksheet selecting rows that contain identical names (Column A)
I then run this macro
It copies these rows into a new worksheet, adds a new row above and gives labels to each column, groups the cells and puts them back where they came from.


My issues are as follows:
1. If I select 10 rows, when the rows need to be copied back into the original sheet there are now 11 rows with the new title. 11 doesn't go into 10 - to try and over come this I ran an insert function which now gives me 20 rows to use. This is a little messy and requires me to use a delete blank row function which seems to be slowing things down.

2. I have to run this macro from the top of the original spreadsheet to the bottom if I run it above where I have already run it it causes misalignment fin all the groupings below. - I'm not sure if this can be overcome.

3. As soon as I try and run the code on more than a few hundred lines it runs painfully slow.


Any help would be greatly appreciated.


Thanks