+ Reply to Thread
Results 1 to 4 of 4

Statement to Automate new sheets if is needed it.

  1. #1
    maperalia
    Guest

    Statement to Automate new sheets if is needed it.

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



  2. #2
    MentalDrow
    Guest

    RE: Statement to Automate new sheets if is needed it.

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

    > 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: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
    > '*************************************************


  3. #3
    maperalia
    Guest

    RE: Statement to Automate new sheets if is needed it.

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

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


  4. #4
    MentalDrow
    Guest

    RE: Statement to Automate new sheets if is needed it.

    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.


    "maperalia" wrote:

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


+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1