Mark and Copy Items from one Sheet to Another

[Gos-C]

Hi all,

I would appreciate it very much if someone helps me clean up the following code to ensure that it accomplishes the desired result.

I have attached a sample file.

The user receives the file (as attached) containing Sheet1, Sheet2 and Sheet3. Sheet1 contains the data. Sheet2 and sheet3 are blank.

The user then has to select a sample of the data as follows:

1. From the “Paid” items in column EE, determine the required number of Rsk items according to the predetermined chart

2. From the “Paid” items in column EE, select the required number of Rsk items

3. Calculate the Sample Size of the “Paid” items in column EE, using the specified Web-based Sample Size Calculator

4. Denote, in column, the Rsk items

5. Randomly selects the number of “Paid” items not already selected in as Rsk items , which is equal to the different between the Sample Size and the required number of Rsk items

6. Copy the selected Rsk selected items and the randomly selected items to another sheet

Notes:

1. The user should not be able to select more than the required number of Rsk items but should be able to cancel a selection and re-select it or a different item

2. If the user closes the file before the process is completed, do not save the file

Here is the code I use:

Option Explicit
Dim tItems As Long, rskMin As Integer, sRange As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Dim sRange As Range
Set sRange = Range("EG2:EG" & Cells(Rows.Count, 1).End(xlUp).Row)
If Target.Cells.Count > 1 _
Or Intersect(Target, Range("EG2:EG" & Cells(Rows.Count, 1).End(xlUp).Row)) Is Nothing Then Exit Sub
If Range("EH1") >= Range("EJ1") Then
MsgBox "Rsk Items target achieved."
End If
        If UCase(Cells(Target.Row, "EE")) <> "PAID" Then Exit Sub
        
            Target.Font.Name = "Marlett"
                If Target = vbNullString Then
                    Target = "a"
                Else
                    Target = vbNullString
                End If
Range("EH1").Value = Application.WorksheetFunction.CountIf(sRange, "a")

End Sub

Sub TestItemsSelection()

Call TotalPaidItems
Call RskChart
Call GetSampleSize
Call RdmSelection
Call SelectItems

End Sub


Sub TotalPaidItems()
    Dim cRange As Range
    Dim rskMin As Long
    Set cRange = Range("EE2:EE" & Cells(Rows.Count, 1).End(xlUp).Row)
    tItems = Application.WorksheetFunction.CountIf(cRange, "Paid")
    Range("EI1").Value = tItems
    Range("EI1").AddComment "Total Paid Items"
    Range("EH1").AddComment "Total Rsk Items Selected = EJ1"
    Range("EJ1").AddComment "Required Minimum Rsk Items Selection"
    Range("EK1").AddComment "Sample Size"
    Range("EL1").AddComment "Total Rdm Items Selected = Sample Size (EK1) minus Rsk (EJ1)"
End Sub



Sub SelectItems()
Dim LastRec As Long, x As Long, ThisValue As Variant, NextRow As Variant
'Dim wsSheet As Worksheet
    Application.DisplayAlerts = False
  
    Sheets("Sheet2").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("Sheet3").Select
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True

'    AddAsLastWorksheet
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Selected Items"
     Sheets("Sheet1").Select
     Range("A1:EF1").Copy
    ' Find the last row of data
    Sheets("Selected Items").Select
    ActiveSheet.Paste
    Application.SendKeys "{ESC}"
    ActiveSheet.Range("EG1").Select
    ActiveCell.FormulaR1C1 = "Select Type"
'
'    Call TotalPaidItems
'
'    Call SampleSizeChart
    
    MsgBox "Please select " & Sheets("sheet1").Range("EJ1") & " Rsk Items by clicking column EG for each of those " _
    & Sheets("sheet1").Range("EJ1") & "Items."
    
    Sheets("Sheet1").Select
    LastRec = Cells(Rows.Count, 1).End(xlUp).Row
    ' Loop through each row
    For x = 2 To LastRec
        ' Decide if to copy based on column EG
        ThisValue = Cells(x, 137).Value
        If ThisValue = "a" Or ThisValue = "x" Then
            Cells(x, 1).Resize(1, 137).Copy
            
            Sheets("Selected Items").Select
            NextRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
            ActiveSheet.Cells(NextRow, 1).Select
            ActiveSheet.Paste
            ActiveSheet.Range("A1").Select
            Sheets("Sheet1").Select
        End If
    Next x
Application.CutCopyMode = False
Sheets("Sheet1").Range("A1").Select
End Sub

Sub GetSampleSize()
Dim sSize As String

Dim MyText As String
  MyText = "Enter the following numbers:    " & vbLf & vbLf & _
      "What margin of error can you accept?" & vbTab & 2 & vbLf & _
      "What confidence level do you need?" & vbTab & 95 & vbLf & _
      "What is the population size?" & vbTab & vbTab & Range("EI1").Value & vbLf & _
      "What is the response distribution?" & vbTab & 2
  ThisWorkbook.FollowHyperlink Address:="http://www.raosoft.com/samplesize.html", NewWindow:=True
  MsgBox MyText


    sSize = Application.InputBox(Prompt:="Please enter the number shown in the Sample Size Calculator for 'Your recommended sample size is'", _
          Title:="ENTER SAMPLE SIZE", Type:=1)
If sSize = vbNullString Then

           Exit Sub
End If

Range("EK1").Value = sSize

End Sub

Sub RskChart()
frmTypeOfTest.Show
End Sub

Public Sub RdmSelection()
    Dim rngSrc As Range, rngFinal As Range
    Dim vData As Variant, vIndex() As Variant
    Dim lngR As Long, lngC As Long, lngK As Long
    Dim dblMax As Double
    Const C_FIRST_ROW = 2
    With Sheets("Sheet1")
        Set rngSrc = .Range(.Cells(C_FIRST_ROW, "EE"), .Cells(.Rows.Count, "EE").End(xlUp)).Resize(, 3)
        vData = rngSrc.Value
        ReDim vIndex(1 To UBound(vData, 1), 1 To 2)
        For lngC = LBound(vIndex, 2) To UBound(vIndex, 2) Step 1
            If lngC = 2 Then
                lngK = Val(.Cells(1, "EK")) - Val(.Cells(1, "EH"))
                If lngK > 0 Then
                    dblMax = Application.Small(Application.Index(vIndex, 0, 1), lngK)
                End If
            End If
            For lngR = LBound(vIndex, 1) To UBound(vIndex, 1) Step 1
                Select Case lngC
                    Case 1
                        If UCase(vData(lngR, 1) & vData(lngR, 3)) = "PAID" Then
                            vIndex(lngR, lngC) = Rnd
                        Else
                            vIndex(lngR, lngC) = 1
                        End If
                    Case 2
                        vIndex(lngR, lngC) = vIndex(lngR, 1) <= dblMax
                        If vIndex(lngR, lngC) Then
                            If rngFinal Is Nothing Then
                                Set rngFinal = .Rows(lngR - 1 + C_FIRST_ROW)
                            Else
                                Set rngFinal = Union(rngFinal, .Rows(lngR - 1 + C_FIRST_ROW))
                            End If
                        End If
                End Select
            Next lngR
        Next lngC
        If Not rngFinal Is Nothing Then
'            rngFinal.Select
            Intersect(.Columns("EG"), rngFinal).Font.Name = "Calibri"
            Intersect(.Columns("EG"), rngFinal).Value = "X"

        End If
    End With
    Set rngSrc = Nothing
    Set rngFinal = Nothing
'    Range("EL1").Value = Application.WorksheetFunction.CountIf(sRange, "x")
End Sub

Thank you,
Gos-C