如何在VB6中按日期对Excel数据进行排序

Question

我想按日期排序，这是我工作表的中间列。 IM从数据库系统中得到我的数据，但我不能在该系统中它排序，我需要整理其到我这里来，因为这数据：

| A FIELD | B FIELD | C FIELD | DATE FIELD | E FIELD | F FIELD | 
| Adata1 | Bdata | Cdata | 09.05.2011 | Edata | Fdata | 
| Adata2 | Bdata | Cdata | 03.05.2011 | Edata | Fdata | 
| Adata3 | Bdata | Cdata | 21.05.2011 | Edata | Fdata | 
| Adata4 | Bdata | Cdata | 01.05.2011 | Edata | Fdata | 
| Adata5 | Bdata | Cdata | 11.05.2011 | Edata | Fdata | 

，我应该找到一种方法，让这样比贴以excel：

| A FIELD | B FIELD | C FIELD | DATE FIELD | E FIELD | F FIELD | 
| Adata4 | Bdata | Cdata | 01.05.2011 | Edata | Fdata | 
| Adata2 | Bdata | Cdata | 03.05.2011 | Edata | Fdata | 
| Adata1 | Bdata | Cdata | 09.05.2011 | Edata | Fdata | 
| Adata5 | Bdata | Cdata | 11.05.2011 | Edata | Fdata | 
| Adata3 | Bdata | Cdata | 21.05.2011 | Edata | Fdata | 

所以我怎么能做到这一点在VB6到Excel？我可以使用它的助手，并从它读取数据顺序/排序比粘贴回到Excel，但哪些助手OLE？

Dim strcnn As String 
Dim cnn As New ADODB.Connection 
Dim Cmd As New ADODB.Command 
Dim rs As New ADODB.Recordset 

Private Sub Form_Load() 
    'Create database connection 
    strcnn = "MyConnectionToDb" 
    cnn.Open strcnn 
    Cmd.ActiveConnection = cnn 
End Sub 


Private Sub Command1_Click() 
    Dim i As Integer 
    Dim cek As String 
    Dim tarih As String 
    'Set excel 
    Set kitap = CreateObject("Excel.Application") 
    kitap.Workbooks.Add 
    'Data Query 
    cek = "SELECT * FROM DATATEST.trolololollololollololoo" 
    rs.Open cek, cnn 
    'If result is empty 
    If rs.EOF = True Then 
     'Report situation 
     Situation.Caption = "Situation : is under control!" 
    Else 
     'Start counter 
     i = i + 1 
     'Add headers 
     kitap.Cells(i, 1).Value = "SN" 
     kitap.Cells(i, 2).Value = "OP" 
     kitap.Cells(i, 3).Value = "HF" 
     kitap.Cells(i, 4).Value = "UC" 
     kitap.Cells(i, 5).Value = "HA" 
     kitap.Cells(i, 6).Value = "UA" 
     kitap.Cells(i, 7).Value = "IN" 
     'While not end of file 
     Do While Not rs.EOF 
      'Increase the Counter 
      i = i + 1 
      'Add the data 
      kitap.Cells(i, 1).Value = rs.Fields("SN") 
      kitap.Cells(i, 2).Value = rs.Fields("OP") 
      kitap.Cells(i, 3).Value = rs.Fields("HF") 
      kitap.Cells(i, 4).Value = rs.Fields("UC") 
      kitap.Cells(i, 5).Value = rs.Fields("HA") 
      kitap.Cells(i, 6).Value = dotdate(rs.Fields("UA")) 'UA is date field, this will be the key column 
      kitap.Cells(i, 7).Value = rs.Fields("IN")   'to sort all data is being saved to excel. 
      'Next record 
      rs.MoveNext 
     Loop 
     'Close data connection 
     rs.Close 
    End If 
    'Save data to excel 
    kitap.ActiveWorkbook.SaveAs(App.Path & "\troll.xls") 
    kitap.Application.Quit 
    'Report situation 
    Situation.Caption = "Situation : Excel Formatted Troll is Ready" 
Exit Sub 
Error: 
    'On error close connection 
    rs.Close 
    'Report situation 
    Situation.Caption = "Critical ERROR! : Connection has been trolled! Reset ur computer." 
End Sub 

Answer 1

我找到了解决办法。这是一个糟糕的代码，但解决了这个问题。

OptionExplit 
Dim strcnn As String 
Dim cnn As New ADODB.Connection 
Dim Cmd As New ADODB.Command 
Dim rs As New ADODB.Recordset 

Private Sub Form_Load() 
    'Create database connection 
    strcnn = "MyConnectionToDb" 
    cnn.Open strcnn 
    Cmd.ActiveConnection = cnn 
End Sub 

'Sorting function here! 
Public Function OrderByDate() 
    Dim i, j, k As Integer 
    Dim temp(100, 50) As Variant 
    'for my work here 100 was enough.. change it if u got more items in ur excel data. 
    Dim xlApp As Excel.Application 
    Dim xlWorkBook As Excel.Workbook 
    Dim xlWorkSheet As Excel.Worksheet 
    'Set excel 
    Set xlApp = New Excel.Application 
    Set xlWorkBook = xlApp.Workbooks.Open(App.Path & "\my.xls") 
    Set xlWorkSheet = xlWorkBook.Worksheets(1) 
    'Start working on worksheet 
    With xlWorkSheet 
     'Start counters 
     i = 2 
     j = 3 
     k = 1 
     'Report situation 
     Situation.Caption = "Situation : Ordering by Date." 
     'Till Excell Book finishes 
     Do While Not k = .Rows.Count - 1 
      'When you reach empty cells in ur sheet it means you're at the end of ur data. 
      'So finish there. 
      If UnDotAndTurn(Replace(Trim(.Cells(j, 6)), ".", "")) = "" Then 
       'Exit 
       Exit Do 
      Else 
       'ReOrder the data 
       If UnDotAndTurn(Replace(Trim(.Cells(i, 6)), ".", "")) > UnDotAndTurn(Replace(Trim(.Cells(j, 6)), ".", "")) Then 
        'First get the values to a template 
        temp(i, 1) = .Cells(j, 1) 
        temp(i, 2) = .Cells(j, 2) 
        temp(i, 3) = .Cells(j, 3) 
        temp(i, 4) = .Cells(j, 4) 
        temp(i, 5) = .Cells(j, 5) 
        temp(i, 6) = .Cells(j, 6) 
        temp(i, 7) = .Cells(j, 7) 
        'Then get the next value into current 
        .Cells(j, 1).Value = .Cells(i, 1) 
        .Cells(j, 2).Value = .Cells(i, 2) 
        .Cells(j, 3).Value = .Cells(i, 3) 
        .Cells(j, 4).Value = .Cells(i, 4) 
        .Cells(j, 5).Value = .Cells(i, 5) 
        .Cells(j, 6).Value = .Cells(i, 6) 
        .Cells(j, 7).Value = .Cells(i, 7) 
        'At last write the values in temp to next value set 
        .Cells(i, 1).Value = temp(i, 1) 
        .Cells(i, 2).Value = temp(i, 2) 
        .Cells(i, 3).Value = temp(i, 3) 
        .Cells(i, 4).Value = temp(i, 4) 
        .Cells(i, 5).Value = temp(i, 5) 
        .Cells(i, 6).Value = temp(i, 6) 
        .Cells(i, 7).Value = temp(i, 7) 
        'return previous data to see if its still-> 
        '->higher than what data comes before it. 
        If i <= 3 Then 
         i = i - 1 
        ElseIf i > 3 Then 
         i = i - 2 
         j = j - 2 
        End If 
       ElseIf UnDotAndTurn(Replace(Trim(.Cells(i, 6).Value), ".", "")) = UnDotAndTurn(Replace(Trim(.Cells(j, 6).Value), ".", "")) Then 
        'do smt here if u need to do! when they are equals to each other 
       ElseIf UnDotAndTurn(Replace(Trim(.Cells(i, 6).Value), ".", "")) < UnDotAndTurn(Replace(Trim(.Cells(j, 6).Value), ".", "")) Then 
        'do smt here if u need to do! when i lower than j 
       End If 
       '+1 to go next data 
       i = i + 1 
       j = j + 1 
       k = k + 1 
      End If 
     Loop 
     'Report situation 
     Situation.Caption = "Situation : Order Finished! Saving." 
     'Save worksheet 
     .SaveAs (App.Path & "\my.xls") 
    End With 
    'Save workbook 
    xlWorkBook.Save 
    xlWorkBook.Close 
    xlApp.Quit 
    'Report situation 
    Situation.Caption = "Situation : Changes Saved!" 
End Function 

'Take date data as string and clear "." and turn it to yyyymmdd together. 
Public Function UnDotAndTurn(ByRef elem) As String 
    Dim Day, Month, Year As String 
    'Clear dots and spaces 
    elem = Trim(elem) 
    elem = Replace(elem, ".", "") 
    'If result is empty 
    If elem = "" Then 
     'Return empty 
     elem = 0 
     UnDotAndTurn = "" 
    ElseIf elem <> "" Then 
     'Get date values 
     Year = Right(elem, 4) 
     Month = Mid(elem, Len(elem) - 5, 2) 
     Day = Mid(elem, 1, Len(elem) - 6) 
     'If "Day" is 1 charachter long than add 0 to head to get this: 09 
     If Len(Day) = 1 Then 
      Day = "0" & Day 
     End If 
     'Return result 
     UnDotAndTurn = Year & Month & Day 
    End If 
End Function 

'i use this while i read data from my db it takes date field as numeric like 9082011 
'and i turn it into 09.08.2011 date format, putting dots to make it more understandable 
Public Function dotdate(ByRef elem) As String 
    Dim Day, Month, Year As String 
    'Get date values 
    Year = Right(elem, 4) 
    Month = Mid(elem, Len(elem) - 5, 2) 
    Day = Mid(elem, 1, Len(elem) - 6) 
    'If "Day" is 1 charachter long than add 0 to head to get this: 09 
    If Len(Day) = 1 Then 
     Day = "0" & Day 
    End If 
    'Return result 
    dotdate = Day & "." & Month & "." & Year 
End Function 

Private Sub Command1_Click() 
    Dim i, j As Integer 
    Dim cek As String 
    Dim xlApp As Excel.Application 
    Dim xlWorkBook As Excel.Workbook 
    Dim xlWorkSheet As Excel.Worksheet 
    'Set excel 
    Set xlApp = New Excel.Application 
    Set xlWorkBook = xlApp.Workbooks.Add 
    Set xlWorkSheet = xlWorkBook.Worksheets(1) 
    'With worksheet 
    With xlWorkSheet 
     'Data Query 
     cek = "Select * From DATATEST.trolololollololollololoo" 
     rs.Open cek, cnn 
     'Start counter 
     j = 1 
     'If result is empty 
     If rs.EOF = True Then 
      'Report situation 
      Situation.Caption = "Situation : End Of File! END OF LIFE! RUN AWAY!" 
     Else 
      'Add headers 
      .Cells(j, 1).Value = "SN" 
      .Cells(j, 2).Value = "OP" 
      .Cells(j, 3).Value = "HF" 
      .Cells(j, 4).Value = "UC" 
      .Cells(j, 5).Value = "HA" 
      .Cells(j, 6).Value = "UA" 
      .Cells(j, 7).Value = "IN" 
      'Increase the Counter 
      j = j + 1 
      'While not end of file 
      Do While Not rs.EOF 
       'Add the data 
       .Cells(j, 1).Value = rs.Fields("SN") 
       .Cells(j, 2).Value = rs.Fields("OP") 
       .Cells(j, 3).Value = rs.Fields("HF") 
       .Cells(j, 4).Value = rs.Fields("UC") 
       .Cells(j, 5).Value = rs.Fields("HA") 
       .Cells(j, 6).Value = dotdate(rs.Fields("UA")) 
       .Cells(j, 7).Value = rs.Fields("IN") 
       'Increase the Counter 
       j = j + 1 
       'Next record 
       rs.MoveNext 
      Loop 
      'Close data connection 
      rs.Close  
     End If 
     'Save worksheet 
     .SaveAs (App.Path & "\my.xls") 
    End With 
    'Save workbook 
    xlWorkBook.Save 
    xlWorkBook.Close 
    xlApp.Quit 
    'Order excel file 
    DoEvents 
    OrderByDate 
    'Report situation 
    Situation.Caption = "Situation : Excel Formatted Troll is Ready" 
Exit Sub   
Error: 
    'On error close connection 
    rs.Close 
    'Report situation 
    Situation.Caption = "Critical ERROR! : Connection has been trolled! Reset ur computer." 
End Sub 

Answer 2

最简单的方法来做你想做的事似乎是从你的数据库返回的数据。相反的：

"Select * From DATATEST.trolololollololollololoo" 

尝试

"Select * From DATATEST.trolololollololollololoo ORDER BY [Date Field Name]" 

Answer 3

说实话 - 我不明白你的问题。事实上，我认为你自己创造了这个问题。为什么不按照原样复制数据，然后运行如下所示的内容？

'set autofilter 
Me.Range(Cells(1,1), Cells(lastRow, lastColumn)).AutoFilter 

'sort 
Me.AutoFilter.Range.Sort Key1:=Cells(rowDateField, 1), Order1:=xlAscending, Header:=xlYes 

排序完成。