[已解决]谢谢gdgzlyh 老师， 提取指定代码的所有明细，并显示查找结果

lhj323323

老师：
我在上传的附件中有详细的说明，是关于按指定列内的所有代码从两个工作表中提取数据明细，并在[操作面]的指定列显示查找的结果。

请问怎么写？谢谢了

最佳答案

月排行榜 / 总排行榜

gdgzlyh

2011-4-4 22:52

Public Sub 例()
    Dim cnn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim myWbName As String, mySheet As String, j As Integer, S As String
    Dim cnnStr As String, SQL As String, n As Integer
    myWbName = ThisWorkbook.FullName
    cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
        & "Extended Properties=Excel 8.0;" _
        & "Data Source=" & myWbName
    cnn.Open cnnStr
    Sheets("结果表").Rows("2:65536").ClearContents
    For j = 6 To Sheets("操作面").Range("i5").End(xlDown).Row
        S = Sheets("操作面").Range("i" & j)
        If Left(S, 1) = 9 Or Left(S, 1) = 6 Then
            mySheet = "数据源A"
        Else
            mySheet = "数据源B"
            S = "'" & S & "'"
        End If
        SQL = "select * from [" & mySheet & "$] where 证券代码=" & S & " ORDER BY 交易日期 ASC"
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
        n = Sheets("结果表").Range("A65536").End(xlUp).Row
        Sheets("结果表").Range("A" & n + 1).CopyFromRecordset rs
        SQL = "select distinct 交易日期 from [" & mySheet & "$] where 证券代码=" & S
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
            If rs.RecordCount = 0 Then
                Sheets("操作面").Range("j" & j) = "无记录"
            Else
                 Sheets("操作面").Range("j" & j) = rs.RecordCount & "天的记录"
            End If
    Next j
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

跳转到最佳答案楼层

lhj323323

回复 lhj323323 的帖子

老师：我写的下面这一段虽能导出结果，请问
下面这段程序还需要怎么优化和提速，同时如何在在[操作面]的J列显示出我想要的数据来
我是逐一对两个数据源进行历遍，分别导入到数组Arr1中，这个办法是否有点笨？
Sub yy()
   Dim aa$, arr, Arr1(), Myr As Long, k%, j% 'Myr&
   Dim Myr2&, Arr2, x%
Application.ScreenUpdating = False
   On Error Resume Next
      Set Sht1 = Sheets("数据源A")
      Set Sht2 = Sheets("操作面")
      Set Sht3 = Sheets("结果表")
   
'情况一：用户指定一支股票代码，测试成功
       'aa = Sht2.[i8].Value
'情况二：用户指定多支股票代码，测试成功
        Myr2 = Sht2.[i65536].End(xlUp).Row
        Arr2 = Sht2.Range("i6:i" & Myr2)
'========主程序A===========================
  With Sht1
       Myr = .Range("a65536").End(xlUp).Row
       arr = .Range("a2:g" & Myr)
    For i = 1 To UBound(arr) '先历遍数据源
       For x = 1 To UBound(Arr2)
            '情况一：用户指定一支股票代码，测试成功
             'If CStr(arr(i, 4)) = CStr(aa) Then '针对用户仅指定一支股票的代码
            '情况二：用户指定多支股票代码，测试成功
             If InStr(arr(i, 4), Arr2(x, 1)) > 0 Then '针对用户指定多支股票的代码
               
                k = k + 1
                ReDim Preserve Arr1(1 To 7, 1 To k)
                For j = 1 To 7
                   Arr1(j, k) = arr(i, j)
                Next
                GoTo 100 '我加的<<<<<<<如是情况一,就不用此句
             End If
       Next x '我加的<<<<<<<如是情况一,就不用此句
100: '我加的<<<<<<<如是情况一,就不用此句
   Next i
  End With
'========主程序B===========================
  With Sheet4
       Myr = .Range("a65536").End(xlUp).Row
       arr = .Range("a2:g" & Myr)
    For i = 1 To UBound(arr) '先历遍数据源
       For x = 1 To UBound(Arr2) '再历遍[网络首页]的K列指定的股票代码,<<<<<<<如是情况一,就不用此句
            '情况二：用户指定多支股票代码，测试成功
             If InStr(arr(i, 4), Arr2(x, 1)) > 0 Then '针对用户指定多支股票的代码
               
                k = k + 1
                ReDim Preserve Arr1(1 To 7, 1 To k)
                For j = 1 To 7
                   Arr1(j, k) = arr(i, j)
                Next
                GoTo 200 '我加的<<<<<<<如是情况一,就不用此句
             End If
       Next x '我加的<<<<<<<如是情况一,就不用此句
200: '我加的<<<<<<<如是情况一,就不用此句
   Next i
  End With
    With Sht3
        .Cells.Clear
        .[a1:g1].Value = Sht1.[a1:g1].Value
        .[a2].Resize(UBound(Arr1, 2), UBound(Arr1, 1)) = Application.Transpose(Arr1)
        .Columns("d:d").NumberFormatLocal = "000000"
       .Rows.Font.Name = "宋体"
       .Rows.Font.Size = 10
     End With
   Application.ScreenUpdating = True
   Sht3.Activate
End Sub

lhj323323

回复 lhj323323 的帖子

请朋友们帮忙看看，先谢谢了。

lhj323323

回复 lhj323323 的帖子

向各位朋友求助

gdgzlyh

看看对你有否帮助！

	Public Sub 例()
1	Dim cnn As New ADODB.Connection
2	Dim rs As New ADODB.Recordset
3	Dim myWbName As String, mySheet As String, j As Integer, S As String
4	Dim cnnStr As String, SQL As String, n As Integer
5	myWbName = ThisWorkbook.FullName
6	cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
7	& "Extended Properties=Excel 8.0;" _
8	& "Data Source=" & myWbName
9	cnn.Open cnnStr
10	Sheets("结果表").Rows("2:65536").ClearContents
11	For j = 6 To Sheets("操作面").Range("i5").End(xlDown).Row
12	S = Sheets("操作面").Range("i" & j)
13	If Left(S, 1) = 9 Or Left(S, 1) = 6 Then
14	mySheet = "数据源A"
15	Else
16	mySheet = "数据源B"
17	S = "'" & S & "'"
18	End If
19	SQL = "select * from [" & mySheet & "$] where 证券代码=" & S & " ORDER BY 交易日期 ASC"
20	Set rs = New ADODB.Recordset
21	rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
22	n = Sheets("结果表").Range("A65536").End(xlUp).Row
23	Sheets("结果表").Range("A" & n + 1).CopyFromRecordset rs
24	SQL = "select distinct 交易日期 from [" & mySheet & "$] where 证券代码=" & S
25	Set rs = New ADODB.Recordset
26	rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
27	If rs.RecordCount = 0 Then
28	Sheets("操作面").Range("j" & j) = "无记录"
29	Else
30	Sheets("操作面").Range("j" & j) = rs.RecordCount & "天的记录"
31	End If
32	Next j
33	rs.Close
34	cnn.Close
35	Set rs = Nothing
36	Set cnn = Nothing
	End Sub

gdgzlyh

Public Sub 例()
    Dim cnn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim myWbName As String, mySheet As String, j As Integer, S As String
    Dim cnnStr As String, SQL As String, n As Integer
    myWbName = ThisWorkbook.FullName
    cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
        & "Extended Properties=Excel 8.0;" _
        & "Data Source=" & myWbName
    cnn.Open cnnStr
    Sheets("结果表").Rows("2:65536").ClearContents
    For j = 6 To Sheets("操作面").Range("i5").End(xlDown).Row
        S = Sheets("操作面").Range("i" & j)
        If Left(S, 1) = 9 Or Left(S, 1) = 6 Then
            mySheet = "数据源A"
        Else
            mySheet = "数据源B"
            S = "'" & S & "'"
        End If
        SQL = "select * from [" & mySheet & "$] where 证券代码=" & S & " ORDER BY 交易日期 ASC"
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
        n = Sheets("结果表").Range("A65536").End(xlUp).Row
        Sheets("结果表").Range("A" & n + 1).CopyFromRecordset rs
        SQL = "select distinct 交易日期 from [" & mySheet & "$] where 证券代码=" & S
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
            If rs.RecordCount = 0 Then
                Sheets("操作面").Range("j" & j) = "无记录"
            Else
                 Sheets("操作面").Range("j" & j) = rs.RecordCount & "天的记录"
            End If
    Next j
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub