How to move records from 3 rd or 2nd column I can able to move from first column... pls help me.....

[rajaram0611]

Private Sub START_Click()

Dim LastRow As Integer
Dim CurrentName As String
Dim StartNmbr As Integer
Dim EndNmbr As Long
Dim MyRow As Long
Dim Destn_Lastrow As Long
Dim Destn_RowCount As Long
Dim lCounter  As Long
Dim Response
Dim xlwb As Workbook
Dim ColorSwitch As Boolean

Response = MsgBox("You are about the clear duplicates and Sort Data", vbOKCancel + vbDefaultButton1 + vbCritical, "Duplicates will be deleted from input")
If Response = vbCancel Then Exit Sub

With ThisWorkbook.Sheets("Input")
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    If LastRow < 5 Then
        MsgBox "Not enough records", vbCritical
        Exit Sub
    End If
   
    'Removing Duplicates from Input Data
    .Range("$A$1:$E$" & LastRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), _
        Header:=xlYes
       
    'Sorting Input Data
    If Sheet1.chkbx_SearchAny.Value = False Then  ' if user wants any value , then we will not sort the data
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range( _
            "A2:A" & LastRow & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
           
        With ThisWorkbook.Sheets("Input").Sort
            .SetRange Range("A2:E" & LastRow & "")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
End With

'Formatting input Data Cells
CellFormatting ThisWorkbook.Sheets("Input").Range("A2:E" & IIf(LastRow > 500, LastRow, 500) & "").Borders(xlEdgeLeft)
CellFormatting ThisWorkbook.Sheets("Input").Range("A2:E" & IIf(LastRow > 500, LastRow, 500) & "").Borders(xlEdgeTop)
CellFormatting ThisWorkbook.Sheets("Input").Range("A2:E" & IIf(LastRow > 500, LastRow, 500) & "").Borders(xlEdgeBottom)
CellFormatting ThisWorkbook.Sheets("Input").Range("A2:E" & IIf(LastRow > 500, LastRow, 500) & "").Borders(xlEdgeRight)
CellFormatting ThisWorkbook.Sheets("Input").Range("A2:E" & IIf(LastRow > 500, LastRow, 500) & "").Borders(xlInsideVertical)
CellFormatting ThisWorkbook.Sheets("Input").Range("A2:E" & IIf(LastRow > 500, LastRow, 500) & "").Borders(xlInsideHorizontal)

'Formatting Output data cells
With ThisWorkbook.Sheets("Output")
    .Columns("A:E").ClearContents
   
    With .Columns("A:E").Interior
        .Pattern = xlNone
        .TintAndShade = 0
       .PatternTintAndShade = 0
    End With
   
    With .Range("A1:E1").Interior
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.399975585192419
    End With

End With
   
With Sheets("Output")
    .Cells(1, 1) = Sheets("Input").Cells(1, 1)
    .Cells(1, 2) = Sheets("Input").Cells(1, 2)
    .Cells(1, 3) = Sheets("Input").Cells(1, 3)
    .Cells(1, 4) = Sheets("Input").Cells(1, 4)
    .Cells(1, 5) = Sheets("Input").Cells(1, 5)
End With

lCounter = Sheet1.no_of_Case.Value * 3   'Number of times unique value to be searched if duplicates are found
CurrentName = Sheet1.Cells(2, 1).Value
StartNmbr = 2
EndNmbr = 2

With ThisWorkbook.Sheets("Input")
    If Sheet1.chkbx_SearchAny.Value = True Then 'If user wants any Random Value then we will not search employee wise
        GetRecords StartNmbr, .Cells(.Rows.Count, "A").End(xlUp).Row, lCounter, ColorSwitch   ' Getting Records
    Else
        For MyRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row + 1
           
                    If .Cells(MyRow, "A").Value = CurrentName Then
                        EndNmbr = EndNmbr + 1
                    Else
                        EndNmbr = EndNmbr - 1
                        If ColorSwitch = False Then
                                ColorSwitch = True
                            Else
                                ColorSwitch = False
                        End If
                        GetRecords StartNmbr, EndNmbr, lCounter, ColorSwitch  ' Getting Records
                        StartNmbr = MyRow
                        EndNmbr = MyRow + 1
                    End If
             
                CurrentName = .Cells(MyRow, "A").Value
         Next MyRow
    End If
End With


With ThisWorkbook.Sheets("Output")
    With .Range("A1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)
        .Cells.EntireColumn.AutoFilter
        .Cells.EntireColumn.AutoFit
    End With

    If Sheet1.chkbx_Export.Value = False Then
        .Select
        .Range("A1").Select
        Exit Sub
    End If
    Set xlwb = Excel.Workbooks.Add
    .Range("A1:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Copy
End With

xlwb.Activate
ActiveSheet.Paste
Application.CutCopyMode = False
xlwb.ActiveSheet.Range("A1").Select

With ActiveSheet
    .Cells.EntireColumn.AutoFit
    Selection.AutoFilter
End With

End Sub

Function GetRecords(ByVal StartNm As Long, ByVal EndNm As Long, ByVal Cntr As Long, ByVal Colr As Boolean)

Dim i   As Long
Dim lRandRow As Long
Dim Destn_RowCount As Long
Dim Destn_Lastrow As Long
Dim OutputStr As String
Dim ColorSwitch As Boolean

With ThisWorkbook.Sheets("Output")
   
    For i = 1 To Cntr
        lRandRow = Int((EndNm - StartNm + 1) * Rnd + StartNm)
        'lRandRow = Int((EndNmbr - StartNmbr + 1) * Rnd + LOWER)

              If VBA.InStr(OutputStr, lRandRow) = 0 And _
                    Not Destn_RowCount >= Sheet1.no_of_Case.Value Then

                         Destn_Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   
                        .Cells(Destn_Lastrow, 1).Value = ThisWorkbook.Worksheets("Input").Cells(lRandRow, 1).Value
                        .Cells(Destn_Lastrow, 2).Value = ThisWorkbook.Worksheets("Input").Cells(lRandRow, 2).Value
                        .Cells(Destn_Lastrow, 3).Value = ThisWorkbook.Worksheets("Input").Cells(lRandRow, 3).Value
                        .Cells(Destn_Lastrow, 4).Value = ThisWorkbook.Worksheets("Input").Cells(lRandRow, 4).Value
                        .Cells(Destn_Lastrow, 5).Value = ThisWorkbook.Worksheets("Input").Cells(lRandRow, 5).Value
                       
                        If Colr = True And Sheet1.chkbx_SearchAny.Value = False Then
                            With .Range(.Cells(Destn_Lastrow, 1), .Cells(Destn_Lastrow, 5)).Interior
                                .ThemeColor = xlThemeColorAccent5
                                .TintAndShade = 0.799981688894314
                            End With
                        End If

                        Destn_RowCount = Destn_RowCount + 1
                        OutputStr = OutputStr & "," & lRandRow
               End If
       
    Next i
End With
 
End Function


Private Sub chkbx_SearchAny_Click()
    If Sheet1.chkbx_SearchAny.Value = True Then
        Sheet1.lbl_info = "Search any " & Sheet1.no_of_Case.Value & " record(s)"
    Else
        Sheet1.lbl_info = "search " & Sheet1.no_of_Case.Value & "  records(s) for each person."
    End If
End Sub

Function CellFormatting(ByVal Rng)
    With Rng
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Function