macro/vba to divide data sheet into two sheet

[gautam5]

Need to divide the data in data sheet into two sheets

1)Only those records should move to the newly created two sheets in which the Date of birth is in DD-MMM-YY format(12-Nov-15).Records where the date of birth is not in said format or is 0,blank,text, numbers etc should get skipped.

2)In the newly created two sheets the value visible in original data sheet should get pasted, and the formula should not get pasted.

3)Input box for, which columns I want to be copied to new sheets (As all the columns need not be copied).Not in term of header but column name like A,B,C,H,I,J

4)input box for, row range for each new sheet (like row 2-400 to sheet1, 450-650 to sheet2).It is not not necessary that all the data will be get divided into two sheets, so the row range for 2nd sheet should not get auto fixed by selection of row range for first sheet. e.g It may happen that records between row 5 to 400 will go to one sheet and records between row 450 to 600 will go to second sheet, rest of record need not be copied to either of sheet.

5)input box to, name the newly created two sheet

6)input box for, name of workbook to which I want to move these newly created sheets and provision for error message if the workbook to which I want to move these sheets is not open.

Thanks

[maniacb]

Here is a first iteration of your requirements. The tool does not yet select only the columns picked, but all the columns up to the last selected column. As per removing inaccurate dated items, the code still does not do that.

Sub Twosheets()
Dim sNewFileName, sFolderName, sws2, sws3, FileToOpen As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr As Worksheet
Dim OpenWB As Workbook
Dim EndDate As Date

Application.ScreenUpdating = False
    Set ws = Sheet1
    On Error GoTo EH
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)

    sws2 = InputBox("Please enter the name for the first worksheet?")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)

    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & Vbnewline & "Enter atleast a,b")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)

    
    EndDate = "1 jan 17"
    With wso
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A1").PasteSpecial xlPasteAll
        lro = Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 1 Step -1
            If IsDate(Cells(i, "B")) Or Cells(i, "B") <= EndDate Then
            Else
                Cells(i, "B").EntireRow.Delete
            End If
        Next i
    End With
    
    With wsr
    ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
    wsr.Range("A1").PasteSpecial xlPasteAll
    lrr = Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 1 Step -1
            If IsDate(Cells(j, "B")) Then
            Else
                Cells(j, "B").EntireRow.Delete
            End If
        Next j
    
    End With
    
EH:
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    
End Sub

[gautam5]

Thank you for your brilliant effort.Few issues i observed
a) can it paste the value instead of formula
b)is it mandatory to keep the date column in column B always.
c)in the top row can it paste the column name of original sheet from which the data got imported,so that I can relate to what data is in what column.
d) what is the use of end date 1-Jan-2017 .Is it like the end date should not be older to 1-jan-2017
e)

Please enter the column letters you want transferred, separated by commas, no spaces. & Vbnewline & Enter atleast a,b")

what is Vbnewline?
and "at least a,b " does it mean like a,b columns are mandatory.
f)it pastes the column to sheet 1 successfully but the sheet 2 remains blank
g)after entering all the details like row no, column names a box named "update values:XXXXXXX" pop ups .What is the purpose of same

Again, thanks for your effort man.

[maniacb]

Working on your observations, but note I repaired item f by editing the code, e) vbnewline is a line break. You shouldn't see it. Resolved with my last edit of code

[gautam5]

I recognize and am thankful for your effort. I am new to coding but have modified the code little bit. The date column being shifted to "N" in my code.The 2nd sheet remains blank. The first sheet is getting copied ok .

Sub Twosheets()
Dim sNewFileName, sFolderName, sws2, sws3, FileToOpen As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr As Worksheet
Dim OpenWB As Workbook
Dim EndDate As Date

Application.ScreenUpdating = False
    Set ws = Sheet1
    On Error GoTo EH
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)

    sws2 = InputBox("Please enter the name for the first worksheet?")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)

    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Enter atleast a,b")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)

    
    EndDate = "1 jan 17"
    With wso
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A1").PasteSpecial xlPasteValues
        lro = Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 1 Step -1
            If IsDate(Cells(i, "B")) Or Cells(i, "B") <= EndDate Then
            Else
                Cells(i, "B").EntireRow.Delete
            End If
        Next i
    End With
    
    With wsr
    ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
    wsr.Range("A1").PasteSpecial xlPasteValues
    lrr = Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 1 Step -1
            If IsDate(Cells(j, "N")) Then
            Else
                Cells(j, "N").EntireRow.Delete
            End If
        Next j
    
    End With
    
EH:
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    
End Sub

[maniacb]

Response:
a) fixed
b) yes, the way it is written right now
c) Repaired
d) what is the use of end date - I use to filter out irrelevant dates. Same with start dates
e) fixed
f) repaired
g) I don't see this pop up. Tell me if you still see it in this code

I didn't understand why you changed to column N. But great if it works for you.

Sub Twosheets()
Dim sNewFileName, sFolderName, sfilename, Pathfile, sws2, sws3, FileToOpen As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim xRgUni, xRg As Range
Dim ws, wso, wsr As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False
    Set ws = Sheet1
    On Error GoTo EH
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)

    sws2 = InputBox("Please enter the name for the first worksheet?")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    
    'MsgBox OpenWB.Name
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Enter atleast a,b")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)

    StartDate = "30 Dec 2005"
    EndDate = "1 jan 2017"
    With wso
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wso.Range("A1").PasteSpecial xlPasteValues
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A2").PasteSpecial xlPasteValues
        lro = Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 1 Step -1
            If IsDate(Cells(i, "B")) Or Cells(i, "B") <= EndDate Or Cells(i, "B") >= StartDate Then
            Else
                Cells(i, "B").EntireRow.Delete
            End If
        Next i
    End With
    
    With wsr
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wsr.Range("A1").PasteSpecial xlPasteValues
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        wsr.Range("A2").PasteSpecial xlPasteValues
        lrr = Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 1 Step -1
            If IsDate(Cells(j, "B")) Or Cells(j, "B") Or Cells(i, "B") >= StartDate <= EndDate Then
            Else
                Cells(j, "B").EntireRow.Delete
            End If
        Next j
    
    End With
    
EH:
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    
End Sub

[gautam5]

Thank you again.
a)i)for date column:Is it possible to retain the original value as it is in the destination cell. i.e If in the cell of date column date is written as 21-Nov-19 it should get pasted as 21-Nov-19 in destination cell as well.Now it is getting converted to number. Also if there is a zero,text or any number it should get pasted as that , in short the value should get pasted as we see them in source cell. If this can be achieved, then that will solve most of my trouble.
ii)for other column:If the value is in percentage can it get pasted as percentage
b)please let me know if in future the date column changes to any other column than "B" then what changes I have to make in the code.
c)it pastes data from row above .A column name will be sufficient ,if the data in original sheet from "j" column then it should write "j"
d)it still pastes data other then date.
e)thank you
f)still checking

Is it possible that if in destination workbook if sheets of same name which are being input exist then it will create sheet with name being input-1
If i input sheet name to be created as "juniors" and "seniors" and if in destination workbook sheet with same name already exist then it will create sheet named "junior1" and "senior1"
Thanks

[maniacb]

a) and ii) resolved with .PasteSpecial xlPasteValuesAndNumberFormats
b) change "B" in code to whatever column has dates
c) I think that is working, or I don't understand point
d) work in progress
e) your welcome
f) ok
Sheet Name request: work in progress

I will update you on wip items asap

[maniacb]

Here is the latest code iteration. It should work to resolve the renaming if sheet exist and removing the non relevant dates. I say should because it works when I manually step through the code, but gives issues when I run it straight. Test it out

Sub Twosheets()
Dim sws2, sws3, FileToOpen As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False
    Set ws = Sheet1
    On Error GoTo EH:
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)
    On Error GoTo -1
    'On Error Resume Next
    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & 1
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error GoTo -1
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Enter atleast a,b")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)

    StartDate = "30 Dec 2005"
    EndDate = "1 jan 2017"
    With wso
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wso.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        lro = wso.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, "B")) _
            Or Cells(i, "B") = 0 Or Cells(i, "B") >= EndDate _
            Or Cells(i, "B") <= StartDate Then
                Cells(i, "B").EntireRow.Delete
            End If
        
        Next i
        Columns.AutoFit
    End With
    With wsr
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wsr.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        wsr.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        lrr = wsr.Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(j, "B")) _
            Or Cells(j, "B") = 0 Or Cells(j, "B") >= EndDate _
            Or Cells(i, "B") <= StartDate Then
                Cells(j, "B").EntireRow.Delete
            End If
        Next j
        Columns.AutoFit
    End With
    
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub

[gautam5]

Following issues appeared
1)The data is not getting copied into second sheet (issue reappeared)
2)blank cells and texts are not getting removed from date column. (the record(whole row) having blank cell or only text in date column should get deleted)

Thanks again

[maniacb]

Alright, here you go. Fingers crossed

Sub Twosheets()
Dim sws2, sws3, FileToOpen As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False
    Set ws = Sheet1
    On Error GoTo EH:
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)
    On Error GoTo -1
    'On Error Resume Next
    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & 1
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error GoTo -1
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Enter atleast a,b")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)

    StartDate = "30 Dec 2005"
    EndDate = "1 jan 2017"
    With wso
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wso.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        .Activate
        lro = wso.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, "B")) _
            Or Cells(i, "B") = 0 Then
                Cells(i, "B").EntireRow.Delete
            End If
        Next i
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
    End With
    With wsr
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wsr.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        wsr.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        .Activate
        lrr = wsr.Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(j, "B")) _
            Or Cells(j, "B") = 0 Then
                Cells(j, "B").EntireRow.Delete
            End If
        Next j
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
     End With
    
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub

[gautam5]

Most of the things are done just few fine tuning needed
1)when I was running the code it divided the wrong sheet many times and I was confused, then I noticed the code is written for "sheet1" and order of my sheet was changed. can u please change that to sheet name(instead of sheet number) "studump"?The sheet number may change but I can keep the sheet name constant. I tried to do it myself but ended up with error.
2)If in destination sheet, sheet with same name exist instead of quitting it should create sheets with name assigned through input and suffixed by random numbers
3)most of the unnecessary data is now getting deleted from date columns .Just need to delete decimal numbers.Please include decimal number in unnecessary data list for date column and delete record(row containing numbers with decimal point in date filed.
4)To delete the unnecessary columns from both the newly created sheet I run the below given macro in both the sheets

Sub Delete_columns_of_junior_sheet_Click()
     Sheets("junior").Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
End Sub

can you integrate this code into the code written by you so that after importing the data this code will run in both the newly created sheet
Also in future code please change date column from "B" to "O"
Thanks again

[maniacb]

Lets see if this does it for you

Sub Twosheets()
Dim sws2, sws3, FileToOpen As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
    On Error GoTo EH:
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)
    On Error GoTo -1
    'On Error Resume Next
    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error GoTo -1
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Enter atleast Column O")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)

    StartDate = "30 Dec 2005"
    EndDate = "1 jan 2017"
    With wso
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wso.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        .Activate
        lro = wso.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, "O")) _
            Or Cells(i, "O") = 0 Or IsNumeric(Cells(i, "O")) Then
                Cells(i, "O").EntireRow.Delete
            End If
        Next i
        wso.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
    End With
    With wsr
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wsr.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        wsr.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        .Activate
        lrr = wsr.Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(j, "O")) _
            Or Cells(j, "O") = 0 Or IsNumeric(Cells(i, "O")) Then
                Cells(j, "O").EntireRow.Delete
            End If
        Next j
        wsr.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
     End With
    
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub

[gautam5]

worked perfectly for first sheet. But again the data did not get copied to 2nd sheet. (problem reappeared).
Need to put these into cells of first row of both newly created sheets A1=student_name,B1=P-Percentage,C1=Cumulative Marks,D1=enroll_Date,E1=K-Percentage,F1=S-value,G1=L-value
Thanks

[maniacb]

Can you provide a sample snippet of data in a sample workbook with all the columns so I can assign them from the start. Thanks

[gautam5]

The data columns ranges from A to around AV. Too long to take a screenshot. After deleting all the columns , these 7 columns will be what I will have to analyse .so after deleting all columns commands, naming the first row as given will do the trick.Attachment 699848

[maniacb]

I am asking for a sample file with the columns showing so I can apply the code to what you will be applying it to.

[gautam5]

The data formats keep changing (order of columns) that is why I needed a input box for columns. I will be also be changing the columns to be deleted time to time.But after deleting all columns these seven columns I will need at the end no matter what is order of the column at the beginning. So naming the header at the end will work.Also the header naming in original data sheet is too complex ,I prefer to use simple header that i can understand easily.

[maniacb]

I suggest we make a question for which column has the dates, then select all the remaining columns through the existing input box. I’ll work on incorporating a better column selection process. Let’s call it a work in progress.

[gautam5]

Yup. If we provide input box for the date column and move only those columns, which are selected then it will be great.Then we can then do away with delete column code also.
I am trying to resolve the issue of data not being getting pasted to 2nd sheet, but getting errors. Also can we get the data trimmed(delete any preceding and following blank spaces) while pasting in new sheet.
Thank you for your constant support.

[maniacb]

what column has the untrimmed data? Working on the rest.

[gautam5]

Names in name column sometimes prefixed or suffixed with blank spaces and using vlookup or match index on such entry given wrong result.The date column too.

[maniacb]

To carry out post 19, my only solution currently filters the bad data out of the source data, is that ok? And is A always the names?

[gautam5]

Thats ok.Yes A is always name

[maniacb]

Here is the new code. I added error trapping too. Trim not resolved yet.

Sub Twosheets_u()
Dim sws2, sws3, FileToOpen, sD As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j, lr, n, op, oq, rp, rq As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date
Dim RngA, Result As Range

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
 
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)

    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error Resume Next 'On Error GoTo -1
Pre1:
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)
    If Err.Number <> 0 Or trg <= src Then
        MsgBox "Don't forget to use commas or use ascending values"
        On Error GoTo -1
        GoTo Pre1
    End If
    On Error Resume Next 'On Error GoTo -1
Pre2:
    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)
    If Err.Number <> 0 Or trg <= src Then
        MsgBox "Don't forget to use commas or use ascending values"
        On Error GoTo -1
        GoTo Pre2
    End If
    On Error Resume Next 'On Error GoTo -1
Pre3:
    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Also Enter date Column")
    vCl = Split(vCol, ",")
    If Err.Number <> 0 Then
        MsgBox "Don't forget to use commas"
        On Error GoTo -1
        GoTo Pre3
    End If
    Ub = UBound(vCl)
    On Error GoTo EH:
    sD = InputBox("Please enter which of the columns hold the dates." & vbNewLine & "Enter one letter")
        
    Set Result = ws.Columns("A")
    lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
    Set RngA = ws.Range("A1:AV" & lr)
    
    With ws
        .Activate
        For i = lr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, sD)) _
            Or Cells(i, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(i, sD).EntireRow.Delete
            End If
        Next i
    End With

    For n = LBound(vCl) To UBound(vCl)
        With ws
            Set Result = Application.Union(ws.Columns(vCl(n)), Result)
        End With
    Next n

    Result.Copy
        wso.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    Result.Copy
        wsr.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    With wso
        .Activate
        For op = lr To trg Step -1
            If (Cells(op, 1)) <> "" Then Cells(op, 1).EntireRow.Delete
        Next op
        For oq = src To 2 Step -1
            If (Cells(oq, 1)) <> "" Then Cells(oq, 1).EntireRow.Delete
        Next oq
        wso.Columns.AutoFit
    End With
    
    With wsr
        .Activate
        For rp = lr To trg2 Step -1
            If (Cells(rp, 1)) <> "" Then Cells(rp, 1).EntireRow.Delete
        Next rp
        For rq = src2 To 2 Step -1
            If (Cells(rq, 1)) <> "" Then Cells(rq, 1).EntireRow.Delete
        Next rq
        wsr.Columns.AutoFit
    End With
   
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub

[gautam5]

getting error."This is an error type mismatch".

[maniacb]

I get the mismatch error when I try to enter the column values without commas. Can you confirm you are using commas with column values?

[gautam5]

affirmative.Using commas and still getting error.

[maniacb]

Here we go again More captures implemented, but when checking for date value in date column, the third cell down is the only value checked in the column. Could be issue if third cell does not have date.

Sub Twosheets_u()
Dim sws2, sws3, FileToOpen, sD As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j, lr, n, op, oq, rp, rq As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date
Dim RngA, Result As Range

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
 
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)

    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error Resume Next
Pre1:
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)
    If Err.Number <> 0 Or trg <= src Then
        MsgBox "Don't forget to use commas or use ascending values"
        On Error GoTo -1
        GoTo Pre1
    End If
    On Error Resume Next
Pre2:
    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)
    If Err.Number <> 0 Or trg2 <= src2 Then
        MsgBox "Don't forget to use commas or use ascending values"
        On Error GoTo -1
        GoTo Pre2
    End If
    On Error Resume Next
Pre3:
    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Also Enter date Column")
    vCl = Split(vCol, ",")
    'MsgBox InStr(vCol, ",")
    If Err.Number <> 0 Or InStr(vCol, ",") = 0 Then
        MsgBox "Don't forget to use commas"
        On Error GoTo -1
        GoTo Pre3
    End If
    Ub = UBound(vCl)
    On Error GoTo EH:
Pre4:
    sD = InputBox("Please enter which of the columns hold the dates." & vbNewLine & "Enter one letter")
    If Not IsDate(ws.Cells(3, sD)) Then 'Possible issue, this line only checks the third cell down
        MsgBox "This column needs to have a date"
        GoTo Pre4
    End If
    Set Result = ws.Columns("A")
    lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
    Set RngA = ws.Range("A1:AV" & lr)
    
    With ws
        .Activate
        For i = lr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, sD)) _
            Or Cells(i, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(i, sD).EntireRow.Delete
            End If
        Next i
    End With

    For n = LBound(vCl) To UBound(vCl)
        With ws
            Set Result = Application.Union(ws.Columns(vCl(n)), Result)
        End With
    Next n

    Result.Copy
        wso.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    Result.Copy
        wsr.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    With wso
        .Activate
        For op = lr To trg Step -1
            If (Cells(op, 1)) <> "" Then Cells(op, 1).EntireRow.Delete
        Next op
        For oq = src To 2 Step -1
            If (Cells(oq, 1)) <> "" Then Cells(oq, 1).EntireRow.Delete
        Next oq
        wso.Columns.AutoFit
    End With
    
    With wsr
        .Activate
        For rp = lr To trg2 Step -1
            If (Cells(rp, 1)) <> "" Then Cells(rp, 1).EntireRow.Delete
        Next rp
        For rq = src2 To 2 Step -1
            If (Cells(rq, 1)) <> "" Then Cells(rq, 1).EntireRow.Delete
        Next rq
        wsr.Columns.AutoFit
    End With
   
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo -1
End Sub

[gautam5]

Getting error this column needs to have a date.

[maniacb]

I think we have different data we are running this code on. Can you run it on the original file you posted. Let's see if that makes a difference. I am thinking the date column may have the trim issue and maybe that is the issue.

[gautam5]

Yup running the code on all data sheet. The code you gave in post 13 is perfect just need to resolve the (i)issue of data being not getting pasted to 2nd sheet (ii) after finishing everything naming the a1 to g1 as given in post 14

[maniacb]

I found I had an error with section Pre2. I've updated post #29

[gautam5]

for code given in post 29
Even if I use comma and 2nd row number is bigger than first row number, it is forming loop of error message "Don't forget to use commas or use ascending values". I can not proceed further.

[maniacb]

Her you go, post #14

Sub Twosheets()
Dim sws2, sws3, FileToOpen, sD As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
    On Error GoTo EH:
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)
    On Error GoTo -1
    'On Error Resume Next
    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error GoTo -1
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Enter atleast Column O")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)
    
    sD = InputBox("Please enter which of the columns hold the dates." & vbNewLine & "Enter one letter")
     
    With wso
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wso.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        .Activate
        lro = wso.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, sD)) _
            Or Cells(i, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(i, sD).EntireRow.Delete
            End If
        Next i
        wso.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wso.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
    End With
    With wsr
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wsr.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        wsr.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        .Activate
        lrr = wsr.Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(j, sD)) _
            Or Cells(j, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(j, sD).EntireRow.Delete
            End If
        Next j
        wsr.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wsr.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
     End With
    
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub

[gautam5]

still data not getting pasted to 2nd sheet.Only got header in 1st row

[maniacb]

Minor difference in sheet activate, that's what I changed last time. It works for me

Sub Twosheets()
Dim sws2, sws3, FileToOpen, sD As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
    On Error GoTo EH:
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)
    On Error GoTo -1
    'On Error Resume Next
    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error GoTo -1
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Enter atleast Column O")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)
    
    sD = InputBox("Please enter which of the columns hold the dates." & vbNewLine & "Enter one letter")
     
    With wso
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wso.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        .Activate
        lro = wso.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, sD)) _
            Or Cells(i, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(i, sD).EntireRow.Delete
            End If
        Next i
        wso.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wso.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
    End With
    With wsr
        .Activate
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wsr.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        wsr.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        
        lrr = wsr.Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(j, sD)) _
            Or Cells(j, sD) = 0 Or IsNumeric(Cells(j, sD)) Then
                Cells(j, sD).EntireRow.Delete
            End If
        Next j
        wsr.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wsr.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
     End With
    
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub

[maniacb]

Maybe there is an issue with the source file we have been using. So here is the file with both sets of code embedded.

[gautam5]

The code in post #37 worked perfectly. Now I am marking this post as solved. Thank you for your constant support, patience and kindness.

Need to filter out (move) some record from "sheet2" (of newly created sheet to some other sheet) on basis of date and match with another list.I was earlier considering this to be done through another macro but if the same can be achieved through this macro then it will be great.

I used the code written by you to create two sheets section1 and section2 in workbook phase ii (attached). I need to move certain records from sheet2 (section2) to sheet "special and senior" on basis following two conditions
1) Extract all record of list of special students a given in column B (from section 2 sheet only) and once extracted delete all record of said students from sheet section2 without leaving blank . There are students whose name are same but they are different students.
2) In sheet 2( section2) students whose date of birth (column k-though in this example this is in column "k" most of time this will be column "C" in sheet 2 of newly created sheet) is greater than date given in cell B12 of sheet "date range" and less than or equal to date given in cell B13 of "sheet date range" , need to be moved to senior student section of "sheet special and senior" row P2 onward with out leaving any blank row in sheet2.

If you can give some more time it will be great. Thanks again
encl:phase ii sheet

[maniacb]

1) This condition isn't clear. Are you asking to remove duplicate birthdays or duplicate names?

[gautam5]

1)a)in column B of sheet "special and senior" there are name of certain students
b) Relevant filed (record) pertaining to each of them should get populated( as values) in "special and senior" sheet
b) after the the details (record) of said student are populated in "special and senior" sheet, it should get deleted from "section 2" sheet
What i need is details of special students and
and students whose date of birth falling between given dates (condition2)
to be in "special and Senior " sheets only and not in 2nd sheet.
Nothing to be done to 1st sheet

[maniacb]

Lets see if this works for you. I wrote code assuming Birthday is in column K

Option Explicit

Sub special()
Dim i, j, lrss, lrs2 As Long
Dim dr, ss, s2 As Worksheet

Set ss = ActiveWorkbook.Sheets("special and senior")
Set s2 = ActiveWorkbook.Sheets("section2")
Set dr = ActiveWorkbook.Sheets("date range")
lrss = ss.Cells(Rows.Count, 2).End(xlUp).Row
lrs2 = s2.Cells(Rows.Count, 1).End(xlUp).Row
'On Error Resume Next
For i = 3 To lrss
    For j = lrs2 To 2 Step -1
        If ss.Cells(i, "B").Value = s2.Cells(j, "A").Value Then
            's2.Range(Cells(j, "B"), Cells(j, "K")).Copy ss.Cells(i, "C")
            s2.Range("B" & j & ":K" & j).Copy ss.Cells(i, "C")
            s2.Cells(j, "A").EntireRow.Delete
        End If
    Next j
Next i

'Birthday column assumed to be K
u = 3
    For j = lrs2 To 2 Step -1
        If s2.Cells(j, "K").Value >= Format(dr.Range("B12"), "dd-mmm-yy") Or s2.Cells(j, "K").Value <= dr.Range("B13") Then
            s2.Range("A" & j & ":K" & j).Copy ss.Cells(u, "P")
            s2.Cells(j, "A").EntireRow.Delete
            u = u + 1
        End If
    Next j
End Sub

[gautam5]

changed the code little bit

Option Explicit

Sub special()
Dim i, u, j, lrss, lrs2 As Long
Dim dr, ss, s2 As Worksheet

Set ss = ActiveWorkbook.Sheets("special and senior")
Set s2 = ActiveWorkbook.Sheets("section2")
Set dr = ActiveWorkbook.Sheets("date range")
lrss = ss.Cells(Rows.Count, 1).End(xlUp).Row
lrs2 = s2.Cells(Rows.Count, 1).End(xlUp).Row
'On Error Resume Next
For i = 3 To lrss
    For j = lrs2 To 2 Step -1
        If ss.Cells(i, "A").Value = s2.Cells(j, "A").Value Then
            's2.Range(Cells(j, "B"), Cells(j, "L")).Copy ss.Cells(i, "B)
            s2.Range("B" & j & ":L" & j).Copy ss.Cells(i, "B")
            s2.Cells(j, "A").EntireRow.Delete
        End If
    Next j
Next i

'Birthday column assumed to be D
u = 3
    For j = lrs2 To 2 Step -1
        If s2.Cells(j, "D").Value > Format(dr.Range("B28"), "dd-mmm-yy") Then
            s2.Range("A" & j & ":L" & j).Copy ss.Cells(u, "O")
            s2.Cells(j, "A").EntireRow.Delete
            u = u + 1
        End If
    Next j
End Sub

1) The only issue while executing first condition is, if there are two or more different student with same name then it is only populating details of one student, and details of other student is coming blank.But it is deleting record of all the students from section2 sheet.
2)the 2nd condition is not executing properly .I think I made a mistake while writing if command

[gautam5]

Need to incorporate this

    With .Range("C1", .Cells(Rows.Count, "C").End(xlUp)) 
        If WorksheetFunction.CountBlank(.Cells) + WorksheetFunction.CountIf(.Cells, 0) = 0 Then Exit Sub 
cells
        .AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=""  
         .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete 
    End With
    .AutoFilterMode = False
End With

in code u have given at post #37 after

wso.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")

and after

wsr.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")

[maniacb]

Code 37 incorporation, I used almost all your code

Sub Twosheets()
Dim sws2, sws3, FileToOpen, sD As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
    On Error GoTo EH:
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)
    On Error GoTo -1
    'On Error Resume Next
    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error GoTo -1
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Enter atleast Column O")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)
    
    sD = InputBox("Please enter which of the columns hold the dates." & vbNewLine & "Enter one letter")
     
    With wso
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wso.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        wso.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        .Activate
        lro = wso.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, sD)) _
            Or Cells(i, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(i, sD).EntireRow.Delete
            End If
        Next i
        wso.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wso.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
        
        With .Range("C1", .Cells(Rows.Count, "C").End(xlUp))
        If WorksheetFunction.CountBlank(.Cells) + WorksheetFunction.CountIf(.Cells, 0) = 0 Then GoTo skipo
'Cells-What is this line for? I commented it out since itdoes not apparently do anything
        .AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=""
         .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
skipo:
    .AutoFilterMode = False
    End With
        
    
    
    With wsr
        .Activate
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        wsr.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        wsr.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        
        lrr = wsr.Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(j, sD)) _
            Or Cells(j, sD) = 0 Or IsNumeric(Cells(j, sD)) Then
                Cells(j, sD).EntireRow.Delete
            End If
        Next j
        wsr.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wsr.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
     
        With .Range("C1", .Cells(Rows.Count, "C").End(xlUp))
        If WorksheetFunction.CountBlank(.Cells) + WorksheetFunction.CountIf(.Cells, 0) = 0 Then GoTo skipr
'Cells-What is this line for?
        .AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=""
         .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
skipr:
     End With
    
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub

[gautam5]

for post #45 thank you and appreciate your patience.

For post #46 is there any way we can keep name as it is , and extract record for both of them from section 2 sheet.

In date just need to modify the condition to >b28 instead of ">=B12 and <=B13"

Please give a look to my code at post #43

[maniacb]

Post #43. Rewrote code to add "1" to duplicate name so there are no more duplicates. Let's see if this works for you

Option Explicit

Sub special()
Dim i, j, lrss, lrs2 As Long
Dim dr, ss, s2 As Worksheet

Set ss = ActiveWorkbook.Sheets("special and senior")
Set s2 = ActiveWorkbook.Sheets("section2")
Set dr = ActiveWorkbook.Sheets("date range")
lrss = ss.Cells(Rows.Count, 2).End(xlUp).Row
lrs2 = s2.Cells(Rows.Count, 1).End(xlUp).Row
lcs2 = s2.Cells(1, Columns.Count).End(xlToLeft).Column
'first sort, then Find dups and add 1 to each, 
Range(Cells(1, 1), Cells(lrs2, lcs2)).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
    For j = 2 To lrs2
        If s2.Cells(j, "A").Value = s2.Cells(j - 1, "A").Value Then
              s2.Cells(j, "A").Value = s2.Cells(j, "A").Value & 1
        End If
    Next j
    
For i = 3 To lrss
    For j = lrs2 To 2 Step -1
        If ss.Cells(i, "B").Value = s2.Cells(j, "A").Value Then
            s2.Range("B" & j & ":K" & j).Copy ss.Cells(i, "C")
            s2.Cells(j, "A").EntireRow.Delete
        End If
    Next j
Next i

'Birthday column assumed to be K
u = 3
lrs2 = s2.Cells(Rows.Count, 1).End(xlUp).Row
    For j = lrs2 To 2 Step -1
        If s2.Cells(j, "K").Value >= Format(dr.Range("B12"), "dd-mmm-yy") Or s2.Cells(j, "K").Value <= dr.Range("B13") Then
            s2.Range("A" & j & ":K" & j).Copy ss.Cells(u, "P")
            s2.Cells(j, "A").EntireRow.Delete
            u = u + 1
        End If
    Next j
End Sub

[gautam5]

#code @post #45 the data did not get pasted to 2nd sheet again.

[maniacb]

for post#45, add .activate in the wsr code a few more times, on others, they are wip

[maniacb]

Post#47, new code for phase ii. I updated the code to assign dup in column BB, then use that designation to add and correct the special table when there are double names. At the end I remove the data in column BB.

I also added the .value property for the filter to work for the senior table. Let me know how it works for you.

Option Explicit

Sub special()
Dim i, j, lrss, lrs2 As Long
Dim dr, ss, s2 As Worksheet

Set ss = ActiveWorkbook.Sheets("special and senior")
Set s2 = ActiveWorkbook.Sheets("section2")
Set dr = ActiveWorkbook.Sheets("date range")
lrss = ss.Cells(Rows.Count, 2).End(xlUp).Row
lrs2 = s2.Cells(Rows.Count, 1).End(xlUp).Row
lcs2 = s2.Cells(1, Columns.Count).End(xlToLeft).Column
'Find dups and add "dup" in column BB to be used to post below
s2.Activate
Range(Cells(1, 1), Cells(lrs2, lcs2)).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
    For j = 2 To lrs2
        If s2.Cells(j, "A").Value = s2.Cells(j - 1, "A").Value Then
              s2.Cells(j, "BB").Value = "dup"
              s2.Cells(j - 1, "BB").Value = "dup"
        End If
    Next j
ss.Activate
For i = 3 To lrss
    For j = lrs2 To 2 Step -1
        If ss.Cells(i, "B").Value = s2.Cells(j, "A").Value And s2.Cells(j, "BB").Value = "dup" Then
            ss.Cells(i, "C").EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
            s2.Range("A" & j & ":K" & j).Copy ss.Cells(i, "B")
            s2.Range("A" & j - 1 & ":K" & j - 1).Copy ss.Cells(i + 1, "B")
            s2.Cells(j, "A").EntireRow.Delete
            s2.Cells(j - 1, "A").EntireRow.Delete
        End If
    Next j
Next i

lrss = ss.Cells(Rows.Count, 2).End(xlUp).Row
For i = 3 To lrss
    For j = lrs2 To 2 Step -1
        If ss.Cells(i, "B").Value = s2.Cells(j, "A").Value And ss.Cells(i, "C").Value = "" Then
            s2.Range("B" & j & ":K" & j).Copy ss.Cells(i, "C")
            s2.Cells(j, "A").EntireRow.Delete
        End If
    Next j
Next i

'Birthday column assumed to be B
u = 3
lrs2 = s2.Cells(Rows.Count, 1).End(xlUp).Row
    For j = lrs2 To 2 Step -1
        'If Format(s2.Cells(j, "B").Value, "dd-mmm-yy") >= Format(dr.Range("B28").Value, "dd-mmm-yy") Then
        If dr.Range("B28").Value <= s2.Cells(j, "B").Value Then
            s2.Range("A" & j & ":K" & j).Copy ss.Cells(u, "P")
            s2.Cells(j, "A").EntireRow.Delete
            u = u + 1
        End If
    Next j
    
s2.Range("B:B").ClearContents
End Sub

[maniacb]

post #45, here is code that populates the second sheet. Let me know how you fare.

Sub Twosheets()
Dim sws2, sws3, FileToOpen, sD As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
    On Error GoTo EH:
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)
    On Error GoTo -1
    'On Error Resume Next
    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error GoTo -1
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Include date column in this list")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)
    
    sD = InputBox("Please enter which of the columns hold the dates." & vbNewLine & "Enter one letter")
     
    With wso
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        .Activate
        wso.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        .Activate
        wso.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        lro = wso.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, sD)) _
            Or Cells(i, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(i, sD).EntireRow.Delete
            End If
        Next i
        wso.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wso.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
        
        With .Range("C1", .Cells(Rows.Count, "C").End(xlUp))
        If WorksheetFunction.CountBlank(.Cells) + WorksheetFunction.CountIf(.Cells, 0) = 0 Then GoTo skipo
            .AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=""
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
skipo:
    .AutoFilterMode = False
    End With
         
    With wsr
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        .Activate
        wsr.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        .Activate
        wsr.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        
        lrr = wsr.Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(j, sD)) _
            Or Cells(j, sD) = 0 Or IsNumeric(Cells(j, sD)) Then
                Cells(j, sD).EntireRow.Delete
            End If
        Next j
        wsr.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wsr.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
     
        With .Range("C1", .Cells(Rows.Count, "C").End(xlUp))
        If WorksheetFunction.CountBlank(.Cells) + WorksheetFunction.CountIf(.Cells, 0) = 0 Then GoTo skipr
            .AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=""
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
skipr:
     End With
    
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub

[gautam5]

#code 50 getting error Compile "Error: Variable not defined" (I guess lcs2)
#code @51 the 2nd sheet still coming blank.
Thanks

[maniacb]

#50 lcs2 is the culprit. just add it to the dim line as below:

Dim i, j, lrss, lrs2, lcs2 As Long

#51 I am pulling my hair. have you tried restarting your machine to clear the cache? Still trying some things on my end

[maniacb]

#51 Try this code. I rearranged the code.

Sub Twosheets()
Dim sws2, sws3, FileToOpen, sD As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
    On Error GoTo EH:
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)
    On Error GoTo -1
    'On Error Resume Next
    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error GoTo -1
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)

    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)

    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Include date column in this list")
    vCl = Split(vCol, ",")
    Ub = UBound(vCl)
    
    sD = InputBox("Please enter which of the columns hold the dates." & vbNewLine & "Enter one letter")
         
    With wsr
        ws.Activate
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        .Activate
        .Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Activate
        ws.Range(vCl(0) & src2 & ":" & vCl(Ub) & trg2).Copy
        .Activate
        .Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        
        lrr = wsr.Cells(Rows.Count, "A").End(xlUp).Row
        For j = lrr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(j, sD)) _
            Or Cells(j, sD) = 0 Or IsNumeric(Cells(j, sD)) Then
                Cells(j, sD).EntireRow.Delete
            End If
        Next j
        wsr.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wsr.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
     
        With .Range("C1", .Cells(Rows.Count, "C").End(xlUp))
        If WorksheetFunction.CountBlank(.Cells) + WorksheetFunction.CountIf(.Cells, 0) = 0 Then GoTo skipr
            .AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=""
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
skipr:
     End With
         
    With wso
        ws.Activate
        ws.Range(vCl(0) & "1:" & vCl(Ub) & "1").Copy
        .Activate
        .Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        ws.Activate
        ws.Range(vCl(0) & src & ":" & vCl(Ub) & trg).Copy
        .Activate
        .Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
        lro = wso.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lro To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, sD)) _
            Or Cells(i, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(i, sD).EntireRow.Delete
            End If
        Next i
        wso.Range("B:B,D:H,J:N,P:Z,AC:XFD").EntireColumn.Delete
        Columns(vCl(0) & ":" & vCl(Ub)).EntireColumn.AutoFit
        wso.Range("A1:G1").Value = Array("student_name", "P-Percentage", "Cumulative Marks", "enroll_Date", "K-Percentage", "S-value", "L-valueDate")
        
        With .Range("C1", .Cells(Rows.Count, "C").End(xlUp))
        If WorksheetFunction.CountBlank(.Cells) + WorksheetFunction.CountIf(.Cells, 0) = 0 Then GoTo skipo
            .AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=""
            .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
skipo:
    .AutoFilterMode = False
    End With

    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo 0
End Sub