Divide up Worksheet

[HilcrRWise]

I have an excel worksheet layed out as follows (numbers = row):

1 - Section Title
2 - Section data 1
3 - Section data 2
4 - Section data 3
etc
20 - blank
21 - Section Title
22 - section data 1
etc

all the different sections are divided by a blank row.
There are no blank rows within each section.
Each section contains a different number of rows.
Each section has multiple columns.

What I want to do is divide this one worksheet in to multipl
worksheets with the same name as the Section Title, and each workshee
only listing the data in its specific section.

Is there a quick and easy way to do this without having to spend age
cutting and pasting

 

[...Patrick]

Try this (on a sample) et adapt tou your problem
Bye


Sub MakeOnglet2()
Dim rngDelete3 As Range
Dim rng3 As Range
Application.ScreenUpdating = False
Sheets("touslesnoms").Select
Set depart = ActiveSheet
s = ActiveSheet.Name
Range("A2").Activate
With ActiveSheet
For Each rng3 In .Range(.Cells(2, 1), _
.Cells(.Rows.Count, 1).End(xlUp))
egaux = UCase(rng3.Value) = UCase(rng3.Offset(1, 0).Value)
Debug.Print rng3.Address
If egaux Then
If rngDelete3 Is Nothing Then
Set rngDelete3 = rng3.EntireRow
Else
Set rngDelete3 = Union(rngDelete3, rng3)
End If
Else
If rngDelete3 Is Nothing Then
Set rngDelete3 = rng3.EntireRow
Else
Set rngDelete3 = Union(rngDelete3, rng3)
End If
If Not rngDelete3 Is Nothing Then
Worksheets.Add
mname = rng3.Value
ActiveSheet.Name = mname
'target = ActiveWorkbook.Name
ActiveWindow.Zoom = 75
depart.Activate
Rows("1:1").Select
Selection.Copy
Sheets(mname).Activate
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
If Not rngDelete3 Is Nothing Then
Set rng1 = Sheets(mname).Range("A2")
rngDelete3.EntireRow.Copy rng1
End If

'depart.Activate
'Sheets(1).Range("A1").Select
Range("A1").Select
Range("A1:T1").Interior.ColorIndex = 24
ActiveWindow.SplitRow = 1
ActiveWindow.FreezePanes = True
Range("A2").Activate
Range("A1").Select
Set rngDelete3 = Nothing
depart.Activate
End If
End If
Next rng3
End With
Range("A1").Select
End Sub



...Patrick
Quoi que vous fassiez, faites le bien .
Connectez vous sur ce forum par :
news://msnews.microsoft.com/microsoft.public.fr.excel