Separate "Year" to several worksheets according to one column....

Question

hello! This task is driving me mad... please help! Instead of manually type in the data, i have used VBA to find the year range, put into one column and delete all duplicate ones. But since excel could give more than 20 years, it would be tedious to do all the filtering manually. AND, now i need excel to separate the rows that contain the specific year range in any one the three columns and put them into a new sheet.

e.g. The years that excel could find in the three columns(F:H) are ( 2001,2003,2006,2010, 2012,2020.....2033).. and they are pasted in column "S" in sheet 1. How could i tell excel create new sheets for the years ( sheets 2001, sheets 2003, sheet2006....),search through column (F:H) in sheet 1 to see if ANY of those columns contain that year, and paste them into the new sheet. To be more specific, in the newly created "Sheet 2001", the entire row where column(F:H) contains "2001" should be pasted. and in the newly created "Sheet 2033", the entire row where column(F:H) contains "2033" should be pasted..

Enclosed please find the reference. http://www.speedyshare.com/files/23851477/Book32.xls I have got sheet "2002" and "2003" here as results but for the real one i will need more years' sheets (as many as how many excel could extract in the previous stage; as shown in column L ) ...... I think this task should be quite usual (extracting by date), but i couldn't google the result....Pleas help!!I am very clueless about how to do LOOPING.. so please advice and give in more details! Thanks

Answer 1

You asked something similar in http://stackoverflow.com/questions/3475385/splite-the-entire-row-with-a-specific-year-value-to-other-worksheet-vba-excel/3475680#3475680 and I said you could use ADO. This is not final code, it is a demonstration:

Dim cn As Object
Dim rs As Object
Dim rs2 As Object
Dim sFile As String
Dim sCon As String
Dim sSQL As String
Dim s As String
Dim i As Integer, j As Integer

''This is not the best way to refer to the workbook
''you want, but it is very convenient for notes
''It is probably best to use the name of the workbook.

sFile = ActiveWorkbook.FullName

''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel

sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFile _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

''Late binding, so no reference is needed

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Set rs2 = CreateObject("ADODB.Recordset")


cn.Open sCon

sSQL = "SELECT Year([ Date]) As YrDate " _
       & "FROM [Sheet1$] " _
       & "UNION " _
       & "SELECT Year([ Date i]) As YrDate " _
       & "FROM [Sheet1$] " _
       & "UNION " _
       & "SELECT Year([ Date ii]) As YrDate " _
       & "FROM [Sheet1$] " _
       & "UNION " _
       & "SELECT Year([Date iii]) As YrDate " _
       & "FROM [Sheet1$] "

rs.Open sSQL, cn, 3, 3

i = 3 ''Start adding worksheets at this number
Do While Not rs.EOF

sSQL = "SELECT Dte, Dta, Nmbr, No2, SerialNo FROM " _
       & "(SELECT [ Date] As Dte, [Data] As Dta, [ No] As Nmbr, " _
       & "[ No 2] As No2, [Serial No] As SerialNo " _
       & "FROM [Sheet1$] " _
       & "UNION ALL " _
       & "SELECT [ Date i] As Dte, [Data] As Dta, [ No] As Nmbr, " _
       & "[ No 2] As No2, [Serial No] As SerialNo " _
       & "FROM [Sheet1$] " _
       & "UNION ALL " _
       & "SELECT [ Date ii] As Dte, [Data] As Dta, [ No] As Nmbr, " _
       & "[ No 2] As No2, [Serial No] As SerialNo " _
       & "FROM [Sheet1$] " _
       & "UNION ALL " _
       & "SELECT [Date iii] As Dte, [Data] As Dta, [ No] As Nmbr, " _
       & "[ No 2] As No2, [Serial No] As SerialNo " _
       & "FROM [Sheet1$] ) " _
       & "WHERE Year(Dte)= " & rs!YrDate

    rs2.Open sSQL, cn, 3, 3

    ''Pick a suitable empty worksheet for the results
    Worksheets.Add
    With Worksheets("Sheet" & i)
        .Cells(1, 1) = rs!YrDate

        For j = 0 To rs2.Fields.Count - 1
            .Cells(2, j + 1) = rs2.Fields(j).Name
        Next

        .Cells(3, 1).CopyFromRecordset rs2
    End With

    rs.MoveNext
    i = i + 1
    rs2.Close
Loop

''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing