Copy data to new sheets

  • Thread starter Thread starter Sverre
  • Start date Start date
S

Sverre

I have a long datasheet in Sheet 1. I would like to automatic put in a new
sheet in the workbook every time there is a new content in column D. If it is
possible to name the sheet after the new contents it would be great.

example:
Anonym 25.11.2008 08:25 Jente Gausdal vg3
Anonym 03.11.2008 13:49 Jente Gjøvik vg3
Anonym 03.11.2008 13:49 Jente Gjøvik vg3

When the content Gausdal change to Gjøvik i want a new sheet in the
woorkbook with the name Gjøvik conteining all data from column A to AC for
all rows with Gjøvik in column D.
I will be greatful for help
 
Sverre, try the below and feedback.

1. Column D should be sorted.
2. Column D should not have characters like "/|\" which are unacceptable
characters for sheetname.
3. Assume there are no sheetnames present with the text in ColD

Sub Macro()
Dim lngRef As Long
Dim lngRow As Long
Dim strRef As String
Dim lngLastRow As Long
Dim myWS1 As Worksheet
Dim myWS2 As Worksheet

Set myWS1 = ActiveSheet
lngLastRow = myWS1.Cells(Rows.Count, "D").End(xlUp).Row
For lngRow = 1 To lngLastRow
If strRef <> "" And myWS1.Range("AC" & lngRow) <> strRef Then
Set myWS2 = Sheets.Add(After:=myWS1)
myWS2.Name = myWS1.Range("D" & lngRow - 1)
myWS1.Range("A" & lngRef, "AC" & lngRow - 1).Copy myWS2.Range("A1")
strRef = Range("A" & lngRow)
lngRef = lngRow
End If
If strRef = "" Then strRef = myWS1.Range("AC" & lngRow): lngRef = lngRow
Next
Set myWS2 = Sheets.Add(After:=myWS1)
myWS2.Name = myWS1.Range("D" & lngRow - 1)
myWS1.Range("A" & lngRef, "AC" & lngRow - 1).Copy myWS2.Range("A1")

End Sub


If this post helps click Yes
 
Hi

I assume your data is sorted by column D before this macro is run.

Sub SplitData()
Dim off As Long
Dim FirstRow As Long
Dim StartCell As Range
Dim sh As Worksheet
Dim NewSh As Worksheet

FirstRow = 2 'Headings in row 1
Set sh = Worksheets("Sheet1")
Set StartCell = sh.Range("D" & FirstRow)
shName = StartCell.Value
Set NewSh = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSh.Name = StartCell.Value
Do Until StartCell.Offset(off, 0) = ""
If shName = StartCell.Offset(off, 0) Then
sh.Range("A" & FirstRow + off, sh.Range("AC" & FirstRow + off)).Copy
_
Destination:=NewSh.Range("A2").Offset(NewOff, 0)
NewOff = NewOff + 1
off = off + 1
Else
Set NewSh = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSh.Name = StartCell.Offset(off, 0).Value
sh.Range("A" & FirstRow + off, sh.Range("AC" & FirstRow + off)).Copy
_
Destination:=NewSh.Range("A2").Offset(NewOff, 0)
shName = NewSh.Name
NewOff = 0
off = off + 1
End If
Loop
End Sub

Best regards,
Per
 
Thank you Jacob.

Debugging:
The program stopps at this statement:
myWS2.Name = myWS1.Range("D" & lngRow - 1)
 
Any sheets were created? Try with the below to know at which sheetname the
error is populated.

Sub Macro()
Dim lngRef As Long
Dim lngRow As Long
Dim strRef As String
Dim lngLastRow As Long
Dim myWS1 As Worksheet
Dim myWS2 As Worksheet

On Error GoTo ErrHandler

Set myWS1 = ActiveSheet
lngLastRow = myWS1.Cells(Rows.Count, "D").End(xlUp).Row
For lngRow = 1 To lngLastRow
If strRef <> "" And myWS1.Range("AC" & lngRow) <> strRef Then
Set myWS2 = Sheets.Add(After:=myWS1)
myWS2.Name = myWS1.Range("D" & lngRow - 1)
myWS1.Range("A" & lngRef, "AC" & lngRow - 1).Copy myWS2.Range("A1")
strRef = Range("A" & lngRow)
lngRef = lngRow
End If
If strRef = "" Then strRef = myWS1.Range("AC" & lngRow): lngRef = lngRow
Next
Set myWS2 = Sheets.Add(After:=myWS1)
myWS2.Name = myWS1.Range("D" & lngRow - 1)
myWS1.Range("A" & lngRef, "AC" & lngRow - 1).Copy myWS2.Range("A1")
myWS1.Activate
ErrHandler:
MsgBox "Sheet name:" & Range("D" & lngRow - 1),,"Row:" & lngRow
End Sub
 
My data is sorted by column D

Than you very much. I have tryed this one as well. I got a massage:
Syntax error in this statment:

_
Destination:=NewSh.Range("A2").Offset(NewOff, 0)
Destination:=NewSh.Range("A2").Offset(NewOff, 0)
 
Hi
The problem is word wrap in you news reader.

the underscore sign "_" should be last charachter on the line above. Like
this:

sh.Range("A" & FirstRow + off, sh.Range("AC" & FirstRow + off)).Copy _
Destination:=NewSh.Range("A2").Offset(NewOff, 0)

Hopes this helps.

Per
 
A dialoxbox ask for sheetname sheet 2.

One sheet was put in. The name was Ark1 or in english sheet 4. I deletet the
first sheet 2. After that it look like the excel put in sheet 3 despite I
have deletet the
sheet 2 after the stop in the program.
 
I tryed it,but it dosent help.

sh.Range("A" & FirstRow + off, sh.Range("AC" & FirstRow + off)).Copy_
Destination:=NewSh.Range("A2").Offset(NewOff, 0)
NewOff = NewOff + 1
off = off + 1
Else
Set NewSh = Worksheets.Add(after:=Sheets(Sheets.Count))
NewSh.Name = StartCell.Offset(off, 0).Value
sh.Range("A" & FirstRow + off, sh.Range("AC" & FirstRow + off)).Copy_
Destination:=NewSh.Range("A2").Offset(NewOff, 0)
shName = NewSh.Name

Have I changed it right ?
 
In a new workbook with one sheet; try with some dummy data.

If this post helps click Yes
 
I should have explicitly said that there has to be a space between the Copy
statement and the underscore:

....Copy _ ' (...Copy"Space"_ )

Regards,
Per
 
Thank you Jacob.
I can't try it befor monday.
My hole excelfil brok down. I am not abel to open it, will not answer. I
will recive a backup fil monday from a back up file
 
Thank you.
I cant try it befor monday, becaus excel can't open the fil any more. I will
get a
back up file Monday
 
Try this one.
Select datasheet(Sheet1?) and run the macro Copy_data2sheet below.
I presume your data start at row 2 and have header in row 1, but column
D don't need to be sorted. this macro refresh all data every time you
run the macro. a name of sheet with Gausdal is like Gausdal__1 to
distinguish data sheets from other sheets if any. if you want to do this
automatically, you have to put the event macro Worksheet_Change like
below into datasheet(Sheet1). if your data is large in size, this would
take time to complete.

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 4 Then
Copy_data2sheet
End If
Application.EnableEvents = True
End Sub

Sub Copy_data2sheet()
Dim Srcsh As Worksheet, Dstsh As Worksheet, sh As Worksheet
Dim rng As Range, Dfilter As Range, Criterarng As Range
Dim strname As String

Application.ScreenUpdating = False

Set Srcsh = ActiveSheet
Set Dfilter = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row)
Dfilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set Criterarng = Dfilter.SpecialCells(xlCellTypeVisible)

For Each rng In Criterarng.Cells
strname = rng.Value
Srcsh.Range("A1").AutoFilter Columns("D").Column, strname
Set rng = Srcsh.AutoFilter.Range
Set rng = rng.Resize(, Columns("AC").Column)

On Error Resume Next
Set Dstsh = Nothing
Set Dstsh = Worksheets(strname & "__1")
If Dstsh Is Nothing Then
Set Dstsh = Worksheets.Add(After:=Worksheets(Sheets.Count))
Dstsh.Name = strname & "__1"
rng.Copy Destination:=Dstsh.Range("A1")
Else
Dstsh.Cells.ClearContents
rng.Copy Destination:=Dstsh.Range("A1")
End If
Next
Srcsh.Select
Srcsh.ShowAllData
Srcsh.AutoFilterMode = False

Application.DisplayAlerts = False
Worksheets(Srcsh.Range("D1").Value & "__1").Delete
For Each sh In Worksheets
If sh.Name Like "*__1" Then
Set rng = Nothing
Set rng = Criterarng.Find(Left(sh.Name, Len(sh.Name) - 3), _
LookIn:=xlValues, LookAt:=xlWhole)
If rng Is Nothing Then
sh.Delete
End If
End If
Next
End Sub

Keiji
 
Thank you very much.
This is close. The program runs and create 3 sheets with right names. Then
it stops Debuggingshows somthing wrong in this statement:
NewSh.Name = StartCell.Offset(off, 0).Value

Another problem is that only a few rows with data ar copyed over.
Regards Sverre
 
Thank you Ron
This works. I am very grateful to you and all the other who helped me out.
Fabulous.
Nekt step for me is to automatic sending the sheet e-mail to the respetive
recipient.
Must I establish a work-book for easc sheet and send it, or is it possible
to send
only tre respective sheet direckt from this woorkbook ?
Regards
Sverre
 
Thank you Jacob. I tryed but the program do not run as expected. Anyway thank
you very much for your help. It is highly valuated. The program from Ron de
Bruin works, so i have implentated his Sub.


Regards Sverre
 
Hi Jacob,

I used your code to copy data and a different sheet, however i am having a
little problem, and dont know how to modify the code, I have a large amount
of data maybe over 20K reconds, all sorted based on col Q, I want the macro
to create a sheet for each change in col Q and copy the data to the sheet and
name the sheet based on Col F. example,

Col A Col Q
John 1
John 1
John 1
John 1
Bob 2
Bob 2
Bob 2
Lisa 3
Lisa 3
Lisa 3
In this case the macro will create three sheets (John, Bob, Lisa) and copy
the data to each sheet.

Thanks in advance
David
 
Back
Top