Statement to Automate new sheets if is needed it.

[maperalia]

I have a program (see below) that read a data with text, split it, then copy
each different number with letter into a sheet, then it makes the text to
column to get numbers only, then find the missing and repeated numbers.
However, I have created manually the sheets to get the final information.
However, I have noticed that I have a data that it has the letter “p†but my
program reads just until â€câ€. So I will need to create more sheets until I
get this letter. In addition I have to adjust my macro to get it run.


I wonder if I can get a statement to make the program create a sheet when it
finds a new letter. So I do not have make a several sheets that I will not
need.

Thanks in adsvance.
Maperalia


'*********PROGRAM STARTS******************************
Option Explicit

Public Sub NMR() 'NMR (Number Missing and Repeated)
RD 'Re-format Data
CPCSS 'CopyPasteAndSplitToAnotherSheet
NO 'NumberOnly
NA 'Number with A
NB 'Number with B
NC 'Number with C
End Sub

Sub RD()

Dim c As Range
Dim s As String
Dim t

Application.ScreenUpdating = False

Sheets("Data Splited").Select
Columns("A:A").Select

For Each c In Selection

t = Trim(c.Value)
If t <> "" Then

If IsNumeric(t) Then
c.Offset(0, 1).Value = t
Else
s = Right(t, 1)
c.Offset(0, Asc(LCase(s)) - 95).Value = t
End If
End If
Next c

Range("B1").Select
End Sub

Sub CPCSS()
Application.ScreenUpdating = False
Sheets("Data Splited").Select
Columns("B:B").Select
Selection.Copy


Sheets("NO").Select
Range("A1").Select
ActiveSheet.Paste

'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'Copy Column C From "Main" Sheet and Paste it into "Number with A" Sheet
Sheets("Data Splited").Select
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("NA").Select
Range("A1").Select
ActiveSheet.Paste
'******************************************************************
'Split Text a
On Error Resume Next
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="a", FieldInfo:=Array(Array(1, 1), Array(2, 1)),
TrailingMinusNumbers:=True
On Error GoTo 0
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'Copy Column D From "Main" Sheet and Paste it into "Number with B" Sheet
Sheets("Data Splited").Select
Columns("D").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("NB").Select
Range("A1").Select
ActiveSheet.Paste

'*************************************************************
'Split Text b
On Error Resume Next
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="b", FieldInfo:=Array(Array(1, 1), Array(2, 1)),
TrailingMinusNumbers:=True
On Error GoTo 0
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'Copy Column E From "Main" Sheet and Paste it into "Number with C" Sheet
Sheets("Data Splited").Select
Columns("E:E").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("NC").Select
Range("A1").Select
ActiveSheet.Paste
'**************************************************************
'Split Text c
On Error Resume Next
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="c", FieldInfo:=Array(Array(1, 1), Array(2, 1)),
TrailingMinusNumbers:=True
On Error GoTo 0
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

Sheets("Data Splited").Select
Range("A1").Select
Application.CutCopyMode = False
End Sub

Sub DeleteEmptyRows()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long

Application.ScreenUpdating = False


With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

Firstrow = ActiveSheet.UsedRange.Cells(1).Row
Lastrow = ActiveSheet.UsedRange.Rows.Count + Firstrow

'delete from the bottom up

For Lrow = Lastrow To Firstrow Step -1

If Application.CountA(Rows(Lrow)) = 0 Then Rows(Lrow).Delete

'This will delete the row if the whole row is empty (all columns)

Next
Application.Calculation = CalcMode
End Sub

Sub NO()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim v()
Dim missing() As Long
Dim i As Long
Dim Lastrow As Long
Dim x As Variant
Dim rngStr As String
Dim n As String
Dim sblock As String
Dim fblock As String
Dim j As String
Dim rng As Range
Dim n1 As String
Dim n2 As String

'*****Find the Minimum and Maximum Number*********
rngStr = Application.InputBox("Enter Range of NUMBERS ONLY")
'*************************************************

Application.ScreenUpdating = False

'*************************************************
'Move Empty Rows
Dim rngBlanks As Range
'Dim wks As Worksheet

Set ws1 = Worksheets("NO")
On Error Resume Next
Set rngBlanks = ws1.Columns("A").SpecialCells(xlBlanks)
On Error GoTo 0

If Not rngBlanks Is Nothing Then rngBlanks.EntireRow.Delete
'*************************************************
n = InStr(1, rngStr, "-", vbTextCompare)
If n <> 0 Then
x = Split(rngStr, "-")
sblock = x(0)
fblock = x(1)
ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
v(j) = i
j = j + 1
Next i
Else
x = Split(rngStr, ",")
sblock = LBound(x)
fblock = UBound(x)
ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
If IsNumeric(x(i)) Then
v(j) = CInt(x(i))
Else
v(j) = x(i)
End If
j = j + 1
Next i
End If

'****Read the Numbers on the Test Numbers Sheet********
Set ws1 = Worksheets("NO")
'******************************************************

'****Write the Missed and Duplicated Number on the Missing and
DuplicatedNumbers Sheet********
Set ws2 = Worksheets("NO")
ws2.Range("e1:f1") = Array("Numbers Only Missing ", "Numbers Only Repeated")
'**********************************************************************************************

With ws1
Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & Lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
If IsError(Application.Match(v(i), rng, 0)) Then
ws2.Cells(n1, 5) = v(i)
n1 = n1 + 1
Else
If Application.CountIf(rng, v(i)) > 1 Then
ws2.Cells(n2, 6) = v(i)
n2 = n2 + 1
End If
End If
Next i

End Sub


Sub NA()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim v()
Dim missing() As Long
Dim i As Long
Dim Lastrow As Long
Dim x As Variant
Dim rngStr As String
Dim n As String
Dim sblock As String
Dim fblock As String
Dim j As String
Dim rng As Range
Dim n1 As String
Dim n2 As String

'*****Find the Minimum and Maximum Number*********
rngStr = Application.InputBox("Enter Range of NUMBER WITH TEXT A")
'*************************************************
Application.ScreenUpdating = False
'*************************************************
'Move Empty Rows
Dim rngBlanks As Range
'Dim wks As Worksheet

Set ws1 = Worksheets("NA")
On Error Resume Next
Set rngBlanks = ws1.Columns("A").SpecialCells(xlBlanks)
On Error GoTo 0

If Not rngBlanks Is Nothing Then rngBlanks.EntireRow.Delete
'*************************************************
n = InStr(1, rngStr, "-", vbTextCompare)
If n <> 0 Then
x = Split(rngStr, "-")
sblock = x(0)
fblock = x(1)
ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
v(j) = i
j = j + 1
Next i
Else
x = Split(rngStr, ",")
sblock = LBound(x)
fblock = UBound(x)
ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
If IsNumeric(x(i)) Then
v(j) = CInt(x(i))
Else
v(j) = x(i)
End If
j = j + 1
Next i
End If

'****Read the Numbers on the Test Numbers Sheet********
Set ws1 = Worksheets("NA")
'******************************************************

'****Write the Missed and Duplicated Number on the Missing and
DuplicatedNumbers Sheet********
Set ws2 = Worksheets("NA")
ws2.Range("e1:f1") = Array("Numbers Missing with a", "Numbers Repeated with
a")
'*****************************************************

With ws1
Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & Lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
If IsError(Application.Match(v(i), rng, 0)) Then
ws2.Cells(n1, 5) = v(i)
n1 = n1 + 1
Else
If Application.CountIf(rng, v(i)) > 1 Then
ws2.Cells(n2, 6) = v(i)
n2 = n2 + 1
End If
End If
Next i

End Sub

Sub NB()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim v()
Dim missing() As Long
Dim i As Long
Dim Lastrow As Long
Dim x As Variant
Dim rngStr As String
Dim n As String
Dim sblock As String
Dim fblock As String
Dim j As String
Dim rng As Range
Dim n1 As String
Dim n2 As String
'*****Find the Minimum and Maximum Number*********
rngStr = Application.InputBox("Enter Range NUMBER WITH TEXT B")
'*************************************************
Application.ScreenUpdating = False
'*************************************************
'Move Empty Rows
Dim rngBlanks As Range
'Dim wks As Worksheet

Set ws1 = Worksheets("NB")
On Error Resume Next
Set rngBlanks = ws1.Columns("A").SpecialCells(xlBlanks)
On Error GoTo 0

If Not rngBlanks Is Nothing Then rngBlanks.EntireRow.Delete
'*************************************************
n = InStr(1, rngStr, "-", vbTextCompare)
If n <> 0 Then
x = Split(rngStr, "-")
sblock = x(0)
fblock = x(1)
ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
v(j) = i
j = j + 1
Next i
Else
x = Split(rngStr, ",")
sblock = LBound(x)
fblock = UBound(x)
ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
If IsNumeric(x(i)) Then
v(j) = CInt(x(i))
Else
v(j) = x(i)
End If
j = j + 1
Next i
End If

'****Read the Numbers on the Test Numbers Sheet********
Set ws1 = Worksheets("NB")
'******************************************************

'Write the Missed and Duplicated Number on the Missing and Duplicated
Numbers Sheet**
Set ws2 = Worksheets("NB")
ws2.Range("e1:f1") = Array("Numbers Missing with b", "Numbers Repeated with
b")
'*****************************************************************

With ws1
Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & Lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
If IsError(Application.Match(v(i), rng, 0)) Then
ws2.Cells(n1, 5) = v(i)
n1 = n1 + 1
Else
If Application.CountIf(rng, v(i)) > 1 Then
ws2.Cells(n2, 6) = v(i)
n2 = n2 + 1
End If
End If
Next i

End Sub

Sub NC()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim v()
Dim missing() As Long
Dim i As Long
Dim Lastrow As Long
Dim x As Variant
Dim rngStr As String
Dim n As String
Dim sblock As String
Dim fblock As String
Dim j As String
Dim rng As Range
Dim n1 As String
Dim n2 As String
'*****Find the Minimum and Maximum Number*********
rngStr = Application.InputBox("Enter Range NUMBER WITH TEXT C")
'*************************************************
Application.ScreenUpdating = False
'*************************************************
'Move Empty Rows
Dim rngBlanks As Range
'Dim wks As Worksheet

Set ws1 = Worksheets("NC")
On Error Resume Next
Set rngBlanks = ws1.Columns("A").SpecialCells(xlBlanks)
On Error GoTo 0

If Not rngBlanks Is Nothing Then rngBlanks.EntireRow.Delete
'*************************************************
n = InStr(1, rngStr, "-", vbTextCompare)
If n <> 0 Then
x = Split(rngStr, "-")
sblock = x(0)
fblock = x(1)
ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
v(j) = i
j = j + 1
Next i
Else
x = Split(rngStr, ",")
sblock = LBound(x)
fblock = UBound(x)
ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
If IsNumeric(x(i)) Then
v(j) = CInt(x(i))
Else
v(j) = x(i)
End If
j = j + 1
Next i
End If

'****Read the Numbers on the Test Numbers Sheet********
Set ws1 = Worksheets("NC")
'******************************************************

'****Write the Missed and Duplicated Number on the Missing and
DuplicatedNumbers Sheet********
Set ws2 = Worksheets("NC")
ws2.Range("e1:f1") = Array("Numbers Missing with c", "Numbers Repeated with
c")
'**********************************************************************************************

With ws1
Lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & Lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
If IsError(Application.Match(v(i), rng, 0)) Then
ws2.Cells(n1, 5) = v(i)
n1 = n1 + 1
Else
If Application.CountIf(rng, v(i)) > 1 Then
ws2.Cells(n2, 6) = v(i)
n2 = n2 + 1
End If
End If
Next i

End Sub

 

[MentalDrow]

I happened to need some thing like what you need. You'll have to add the
coding before this in an IF...Then Statement to have it activate when a
certain letter occurs

'Creates a new Worksheet, names it and places it at the end of the Workbook'
Workbooks(<Insert File Name).Activate
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Worksheets("Sheet1").Activate
Sheets("Sheet1").Name = "<Insert Sheet Name>"

 

[maperalia]

MentalDrow;
Thanks for the information. However, I wonder if you can tell me where
exactly I have to put your statement and what statements do I have to delete
in my program to make it run?.
Thanks
Maperalia

 

[MentalDrow]

I'm still pretty new to the whole macro programing thing. I can get around
but refer to these discussion groups myself when needed. So, I really
couldn't tell you IF you need to delete any of your code, let alone where.
With that being said I'll tell you what I would do and you can tell me if it
works or not.

First, is there anywhere in your coding that compares or checks your data
for the change in letters you're talking about? If so, that is where you
would need to put the coding to add the page(s). Example:

Dim CurrVar as String
Dim PrevVar as String
Dim RwCount as Integer
Dim I as Integer

RwCount=ActiveSheet.Rows.Count
PrevVar="" 'This sets both variables to the same value for starting out
CurrVar=""
For I=1 to RwCount
If CurrVar=PrevVar then... 'Here is where you would want your macro to
continue on without creating a new worksheet
Else
'Creates a new Worksheet, names it and places it at the end of the Workbook'
'Workbooks(<Insert File Name>).Activate <-----Take the ' out and this
statement if the macro runs from a different file than the one you're working
on...

ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
' Worksheets("Sheet1").Activate
'Sheets("Sheet1").Name = "<Insert Sheet Name>" You can also take the '
out (here and the previous line) and this statement if you want name the
worksheet through some method

End If
PrevVar=CurrVar
Somewhere in here is where you would write the coding to examine the cell
you're referencing and assign its value to CurrVar. I'll use column "A" in
this example. Example:

If I<RwCount then CurrVar = Range("A" & I+1)
Else CurrVar=Range("A"&I)
End If
Next I

And then you would continue from there. As I said, I'm not an expert so I
may be off on some of the syntax for the coding. If nothing else I hope this
at least gets you rolling in the right direction.