macro to create, name sheet and copy.

S

sutha

Could someone please help me modify the following macro and use.
In this Macro the range is set as every 20 raws. I like to use with data
that has different size range. Can I set a page break for each company range
and use? If so
how to change below/
Thanks

Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim nCol As Long ' number of columns
Dim strCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

nCol = ActiveSheet.UsedRange.Columns.Count
Set rngC1 = ActiveSheet.UsedRange.Range("A1") ' first cell
Do While rngC1.Value <> ""
strCName = Split(rngC1.Value, " ")(0) ' first word is company

Set rngC1 = rngC1.Resize(20, nCol) ' range is the company's

Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '

wsC1.Name = strCName ' name the sheet
rngC1.Copy Destination:=wsC1.[A1] ' copy to it
Set rngC1 = rngC1.Range("A1").Offset(20) ' next company
Loop
End Sub
 
J

Joel

Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim FirstRow As Long
Dim RowCount As Long
Dim NewCName As String ' company name
Dim OldCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

Set OldSht = ActiveSheet
FirstRow = 1
LastRow = OldSht.Range("A" & Rows.Count).End(xlUp).Row
OldCName = Split(OldSht.Range("A1").Value, " ")(0)
For RowCount = 1 To LastRow
NewCName = Split(OldSht.Range("A" & (RowCount + 1)).Value, " ")(0)
If OldCName <> NewCName Then
Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '
wsC1.Name = OldCName ' name the sheet
Set rngC1 = OldSht.Rows(FirstRow & ":" & RowCount)
rngC1.Copy Destination:=wsC1.Rows(1) ' copy to it
FirstRow = RowCount + 1
OldCName = NewCName
End If
Next RowCount
End Sub
 
S

sutha

Thanks Joel.
I copied and ran and got an error message as"run time error'9' subscript out
of range. Please bear with me. I am not with macro knowledge. Your help is
much appreciated.

Joel said:
Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim FirstRow As Long
Dim RowCount As Long
Dim NewCName As String ' company name
Dim OldCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

Set OldSht = ActiveSheet
FirstRow = 1
LastRow = OldSht.Range("A" & Rows.Count).End(xlUp).Row
OldCName = Split(OldSht.Range("A1").Value, " ")(0)
For RowCount = 1 To LastRow
NewCName = Split(OldSht.Range("A" & (RowCount + 1)).Value, " ")(0)
If OldCName <> NewCName Then
Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '
wsC1.Name = OldCName ' name the sheet
Set rngC1 = OldSht.Rows(FirstRow & ":" & RowCount)
rngC1.Copy Destination:=wsC1.Rows(1) ' copy to it
FirstRow = RowCount + 1
OldCName = NewCName
End If
Next RowCount
End Sub


sutha said:
Could someone please help me modify the following macro and use.
In this Macro the range is set as every 20 raws. I like to use with data
that has different size range. Can I set a page break for each company range
and use? If so
how to change below/
Thanks

Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim nCol As Long ' number of columns
Dim strCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

nCol = ActiveSheet.UsedRange.Columns.Count
Set rngC1 = ActiveSheet.UsedRange.Range("A1") ' first cell
Do While rngC1.Value <> ""
strCName = Split(rngC1.Value, " ")(0) ' first word is company

Set rngC1 = rngC1.Resize(20, nCol) ' range is the company's

Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '

wsC1.Name = strCName ' name the sheet
rngC1.Copy Destination:=wsC1.[A1] ' copy to it
Set rngC1 = rngC1.Range("A1").Offset(20) ' next company
Loop
End Sub
Click to expand...
Click to expand...
 
J

Joel

there are two reasons Error 9 can occur

1) The sheet with original sheet with data wasn't selected. I made the
following change in my new code below

from
Set OldSht = ActiveSheet

to
Set OldSht = Sheets("Sheet1")

Note : change Sheet1 t the sheet where your original data is located.

2) An error will occur on the last row of data because the next row contains
an empty cell in Column A. Split produces an error when the string is empty

This line created the error
NewCName = Split(OldSht.Range("A" & (RowCount + 1)).Value, " ")(0)


I added a new test in the code below checking if the cell is empty on the
next row.



Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim FirstRow As Long
Dim RowCount As Long
Dim NewCName As String ' company name
Dim OldCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

Set OldSht = Sheets("Sheet1")
FirstRow = 1
LastRow = OldSht.Range("A" & Rows.Count).End(xlUp).Row
OldCName = Split(OldSht.Range("A1").Value, " ")(0)
For RowCount = 1 To LastRow
If OldSht.Range("A" & (RowCount + 1)) = "" Then
NewCName = ""
Else
NewCName = Split(OldSht.Range("A" & (RowCount + 1)).Value, " ")(0)
End If
If OldCName <> NewCName Then
Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '
wsC1.Name = OldCName ' name the sheet
Set rngC1 = OldSht.Rows(FirstRow & ":" & RowCount)
rngC1.Copy Destination:=wsC1.Rows(1) ' copy to it
FirstRow = RowCount + 1
OldCName = NewCName
End If
Next RowCount
End Sub


sutha said:
Thanks Joel.
I copied and ran and got an error message as"run time error'9' subscript out
of range. Please bear with me. I am not with macro knowledge. Your help is
much appreciated.

Joel said:
Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim FirstRow As Long
Dim RowCount As Long
Dim NewCName As String ' company name
Dim OldCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

Set OldSht = ActiveSheet
FirstRow = 1
LastRow = OldSht.Range("A" & Rows.Count).End(xlUp).Row
OldCName = Split(OldSht.Range("A1").Value, " ")(0)
For RowCount = 1 To LastRow
NewCName = Split(OldSht.Range("A" & (RowCount + 1)).Value, " ")(0)
If OldCName <> NewCName Then
Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '
wsC1.Name = OldCName ' name the sheet
Set rngC1 = OldSht.Rows(FirstRow & ":" & RowCount)
rngC1.Copy Destination:=wsC1.Rows(1) ' copy to it
FirstRow = RowCount + 1
OldCName = NewCName
End If
Next RowCount
End Sub


sutha said:
Could someone please help me modify the following macro and use.
In this Macro the range is set as every 20 raws. I like to use with data
that has different size range. Can I set a page break for each company range
and use? If so
how to change below/
Thanks

Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim nCol As Long ' number of columns
Dim strCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

nCol = ActiveSheet.UsedRange.Columns.Count
Set rngC1 = ActiveSheet.UsedRange.Range("A1") ' first cell
Do While rngC1.Value <> ""
strCName = Split(rngC1.Value, " ")(0) ' first word is company

Set rngC1 = rngC1.Resize(20, nCol) ' range is the company's

Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '

wsC1.Name = strCName ' name the sheet
rngC1.Copy Destination:=wsC1.[A1] ' copy to it
Set rngC1 = rngC1.Range("A1").Offset(20) ' next company
Loop
End Sub
Click to expand...
Click to expand...
Click to expand...
 
S

sutha

Works perfectly. I rated as helpful.
Thanks

Joel said:
there are two reasons Error 9 can occur

1) The sheet with original sheet with data wasn't selected. I made the
following change in my new code below

from
Set OldSht = ActiveSheet

to
Set OldSht = Sheets("Sheet1")

Note : change Sheet1 t the sheet where your original data is located.

2) An error will occur on the last row of data because the next row contains
an empty cell in Column A. Split produces an error when the string is empty

This line created the error
NewCName = Split(OldSht.Range("A" & (RowCount + 1)).Value, " ")(0)


I added a new test in the code below checking if the cell is empty on the
next row.



Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim FirstRow As Long
Dim RowCount As Long
Dim NewCName As String ' company name
Dim OldCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

Set OldSht = Sheets("Sheet1")
FirstRow = 1
LastRow = OldSht.Range("A" & Rows.Count).End(xlUp).Row
OldCName = Split(OldSht.Range("A1").Value, " ")(0)
For RowCount = 1 To LastRow
If OldSht.Range("A" & (RowCount + 1)) = "" Then
NewCName = ""
Else
NewCName = Split(OldSht.Range("A" & (RowCount + 1)).Value, " ")(0)
End If
If OldCName <> NewCName Then
Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '
wsC1.Name = OldCName ' name the sheet
Set rngC1 = OldSht.Rows(FirstRow & ":" & RowCount)
rngC1.Copy Destination:=wsC1.Rows(1) ' copy to it
FirstRow = RowCount + 1
OldCName = NewCName
End If
Next RowCount
End Sub


sutha said:
Thanks Joel.
I copied and ran and got an error message as"run time error'9' subscript out
of range. Please bear with me. I am not with macro knowledge. Your help is
much appreciated.

Joel said:
Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim FirstRow As Long
Dim RowCount As Long
Dim NewCName As String ' company name
Dim OldCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

Set OldSht = ActiveSheet
FirstRow = 1
LastRow = OldSht.Range("A" & Rows.Count).End(xlUp).Row
OldCName = Split(OldSht.Range("A1").Value, " ")(0)
For RowCount = 1 To LastRow
NewCName = Split(OldSht.Range("A" & (RowCount + 1)).Value, " ")(0)
If OldCName <> NewCName Then
Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '
wsC1.Name = OldCName ' name the sheet
Set rngC1 = OldSht.Rows(FirstRow & ":" & RowCount)
rngC1.Copy Destination:=wsC1.Rows(1) ' copy to it
FirstRow = RowCount + 1
OldCName = NewCName
End If
Next RowCount
End Sub


:

Could someone please help me modify the following macro and use.
In this Macro the range is set as every 20 raws. I like to use with data
that has different size range. Can I set a page break for each company range
and use? If so
how to change below/
Thanks

Private Sub XfrCompPL()
Dim rngC1 As Range ' the range for Company
Dim nCol As Long ' number of columns
Dim strCName As String ' company name
Dim wsC1 As Worksheet ' target new worksheet name

nCol = ActiveSheet.UsedRange.Columns.Count
Set rngC1 = ActiveSheet.UsedRange.Range("A1") ' first cell
Do While rngC1.Value <> ""
strCName = Split(rngC1.Value, " ")(0) ' first word is company

Set rngC1 = rngC1.Resize(20, nCol) ' range is the company's

Set wsC1 = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '

wsC1.Name = strCName ' name the sheet
rngC1.Copy Destination:=wsC1.[A1] ' copy to it
Set rngC1 = rngC1.Range("A1").Offset(20) ' next company
Loop
End Sub
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Compare Data between 2 columns, Excel 2000 & 2003 3
macro add 10
Copy a range data from 1 sheet to multiple selected sheets 1
problems getting this macro to work 23
shorten worksheet name 1
Why is this code not working ? 3
Need Help With Macro to set a value in new sheets 2
List unique items 4

Top