macro to create, name sheet and copy.
 

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

macro to create, name sheet and copy.
 

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" wrote:

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

macro to create, name sheet and copy.
 

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" wrote:

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" wrote:

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

macro to create, name sheet and copy.
 

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" wrote:

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" wrote:

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" wrote:

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

macro to create, name sheet and copy.
 

Works perfectly. I rated as helpful.
Thanks

"Joel" wrote:

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" wrote:

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" wrote:

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" wrote:

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