求大神帮助，怎样只保留周五的收盘价

追梦人亮

求大神帮助，下表数据中怎样把每个表中除了周五外其他的收盘价所对应的行都删除，谢谢啦

zhp3

公式

1. =WEEKDAY(A3,2)

复制代码

计算对应的星期，再筛选删除
123.zip (176 KB, 下载次数: 3)

2013-12-6 14:06 上传

点击文件名下载附件

追梦人亮

zhp3 发表于 2013-12-6 14:06
公式计算对应的星期，再筛选删除

你好，谢谢能不能实现程序化操作，因为我要删除的表比较多，
下面是我编的一个但老出问题
Sub Test()
    Dim A()
    Dim i, j, n, y
    For j = 1 To Sheets.Count
        With Sheets(j).Select
        n = Range("a65536").End(xlUp).Row
    For i = 1 To n - 2
        A(i, 1) = Sheets(j).Range(i + 2, 1).Value
          If Application.WorksheetFunction.Weekday(A(i, 1), 2) <> 5 Then A(i, 3) = 1 '标记非星期五
       Next i
            On Error Resume Next
            Application.DisplayAlerts = False
            .Range("c:c").SpecialCells(xlCellTypeConstants).EntireRow.Delete
            On Error GoTo 0
        End With
    Next j
End Sub

hwc2ycy

这个用SQL来实现也不错了。

hwc2ycy

1. Sub ADOtest()
   
2.     Dim AdoConn As Object, AdoRst As Object
   
3.     Dim StrConn$
   
4.     Dim strSQL$, strCondition$
   
5.    
   
6.     Const adUseClient = 3
   
7.     Const adModeRead = 1
   
8. 
   
9.     On Error GoTo ErrorHandler
   
10.    
    
11.     Set AdoConn = CreateObject("ADODB.Connection")
    
12.    
    
13.     strSQL = "select  * from ["
    
14.     strCondition = "$a2:b] where weekday(日期,2)=5"
    
15. 
    
16.     Select Case Application.Version
    
17.         Case "14.0", "12.0"
    
18.             StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source='" & ThisWorkbook.FullName & "';Extended Properties='Excel 12.0;HDR=1;imex=1';"
    
19.         Case Else
    
20.             StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & "Data Source='" & ThisWorkbook.FullName & "';Extended Properties='Excel 8.0;HDR=1;imex=1';"
    
21.     End Select
    
22.     Application.ScreenUpdating = False
    
23.     Application.DisplayAlerts = False
    
24.    
    
25.     With AdoConn
    
26.         .CommandTimeout = 5
    
27.         .ConnectionTimeout = 5
    
28.         .CursorLocation = adUseClient
    
29.         .Mode = adModeRead
    
30.         .ConnectionString = StrConn
    
31.         .Open
    
32.     End With
    
33. 
    
34.     For Each sht In Worksheets
    
35.         With sht.Range("a2")
    
36.             .Resize(, 2).Value = Array("日期", "收盘")
    
37.             Set AdoRst = AdoConn.Execute(strSQL & sht.Name & strCondition)
    
38.             .CurrentRegion.Offset(2).ClearContents
    
39.             .Offset(1).CopyFromRecordset AdoRst
    
40.         End With
    
41.     Next
    
42.     Application.ScreenUpdating = True
    
43.     Application.DisplayAlerts = True
    
44. 
    
45.     MsgBox "提取完成"
    
46.     Set AdoConn = Nothing
    
47.     Exit Sub
    
48. 
    
49. ErrorHandler:
    
50.     Application.ScreenUpdating = True
    
51.     Application.DisplayAlerts = True
    
52.     MsgBox Err.Number & vbCrLf & Err.Description
    
53.     Set AdoRst = Nothing
    
54.     Set AdoConn = Nothing
    
55. End Sub
    

复制代码

hwc2ycy

代码执行后，所有非周五的交易记录全没了，如果担心数据的话，记得先备份吧。
另外，格式要求与你附件的一致，这样代码就能执行正确。