[已解决]SQL调用程序出不了数据

张雄友

SQL调用程序出不了数据。
把    'On Error Resume Next 注释掉，发现：
'strSQL = "select 姓名,身份证号 from [" & s & "]" '把这句去掉就出错了,但是不去掉,就等于说上面“载入数据”这个程序是多余的。没有实现调用的过程，不知问题出在哪里？？？？？？？？？

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-5-5 22:25

1. Dim strSQL, S, myPath$, OutputSheet$, OutputRange$
   
2. Sub 载入数据()
   
3.     strSQL = "select 姓名,身份证号 from "
   
4.     '条件 = "WHERE 姓名='王丽力'"
   
5.     OutputSheet = "结果"
   
6.     OutputRange = "A2"
   
7.     Call subProgram(strSQL, Pathstr, OutputSheet, OutputRange, "WHERE 姓名='王丽力'")    '调用子程序
   
8.     MsgBox "OK"
   
9. End Sub
   
10. 
    
11. Sub subProgram(ByVal strSQL$, ByVal myPath$, ByVal OutputSheet$, ByVal OutputRange$, strCondition$)    '子程序
    
12.     Dim cnn As Object, Rst As Object, rs As Object
    
13.     Dim strConn As String
    
14.     Dim i As Integer, j%, Pathstr, S$, t$, sProvider$
    
15.     Pathstr = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="打开Excel文件", MultiSelect:=True)    '选择多个EXCCEL 文件
    
16.     If TypeName(Pathstr) = "Boolean" Then Exit Sub
    
17.     Application.ScreenUpdating = False
    
18.     Select Case Application.Version * 1
    
19.         Case Is <= 11
    
20.             sProvider = "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0';Data Source ="
    
21.         Case Is >= 12
    
22.             sProvider = "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties ='Excel 12.0';Data Source ="
    
23.     End Select
    
24.     Cells.ClearContents
    
25.     On Error Resume Next    '
    
26.     myPath = S
    
27.     For i = 1 To UBound(Pathstr)
    
28.         If Pathstr(i) <> ThisWorkbook.FullName Then
    
29.             Set cnn = CreateObject("ADODB.Connection")
    
30.             cnn.Open sProvider & Pathstr(i)
    
31.             Set rs = cnn.OpenSchema(20)
    
32.             Do Until rs.EOF
    
33.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
34.                     S = Replace(rs("TABLE_NAME").Value, "'", "")
    
35.                     If Right(S, 1) = "$" Then
    
36. 
    
37.                         Set Rst = cnn.Execute(strSQL & " [" & S & "] " & strCondition)
    
38.                         If Err.Number = 0 Then
    
39.                             m = m + 1
    
40.                             If m = 1 Then
    
41.                                 For j = 0 To Rst.Fields.Count - 1
    
42.                                     Cells(1, j + 1) = Rst.Fields(j).Name
    
43.                                 Next
    
44.                                 Range("A2").CopyFromRecordset Rst
    
45.                             Else
    
46.                                 Range("A65536").End(xlUp).Offset(1).CopyFromRecordset Rst
    
47.                             End If
    
48.                             Exit Do
    
49.                         Else
    
50.                             Err.Clear
    
51.                         End If
    
52.                     End If
    
53.                 End If
    
54.                 rs.MoveNext
    
55.             Loop
    
56.         End If
    
57.     Next
    
58.     Cells.EntireColumn.AutoFit
    
59.     Rst.Close
    
60.     rs.Close
    
61.     cnn.Close
    
62.     Set cnn = Nothing
    
63.     Set rs = Nothing
    
64.     Set Rst = Nothing
    
65.     Application.ScreenUpdating = True
    
66. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

strSQL是空的，肯定要报错。

你查别的表，该表里不是不有这些字段，这都要考虑到的，否则你就要考虑到容错机制。

张雄友

hwc2ycy 发表于 2014-5-5 21:28
strSQL是空的，肯定要报错。

你查别的表，该表里不是不有这些字段，这都要考虑到的，否则你就要考虑到容 ...

where 语句放在哪里？设置不对的。

1. Dim strSQL, S, myPath$, OutputSheet$, OutputRange$
   
2. Sub 载入数据()
   
3.     strSQL = "select 姓名,身份证号 from "
   
4.     条件 = "WHERE 姓名='王丽力'"
   
5.     OutputSheet = "结果"
   
6.     OutputRange = "A2"
   
7.     Call subProgram(strSQL, Pathstr, OutputSheet, OutputRange) '调用子程序
   
8.     MsgBox "OK"
   
9. End Sub
   
10. 
    
11. Sub subProgram(ByVal strSQL$, ByVal myPath$, ByVal OutputSheet$, ByVal OutputRange$) '子程序
    
12.     Dim cnn As Object, Rst As Object, rs As Object
    
13.     Dim strConn As String
    
14.     Dim i As Integer, j%, Pathstr, S$, t$, sProvider$
    
15.     Pathstr = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="打开Excel文件", MultiSelect:=True) '选择多个EXCCEL 文件
    
16.     If TypeName(Pathstr) = "Boolean" Then Exit Sub
    
17.     Application.ScreenUpdating = False
    
18.     Select Case Application.Version * 1
    
19.         Case Is <= 11
    
20.             sProvider = "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0';Data Source ="
    
21.         Case Is >= 12
    
22.             sProvider = "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties ='Excel 12.0';Data Source ="
    
23.     End Select
    
24.     Cells.ClearContents
    
25.     On Error Resume Next '
    
26.     myPath = S
    
27.     For i = 1 To UBound(Pathstr)
    
28.         If Pathstr(i) <> ThisWorkbook.FullName Then
    
29.             Set cnn = CreateObject("ADODB.Connection")
    
30.             cnn.Open sProvider & Pathstr(i)
    
31.             Set rs = cnn.OpenSchema(20)
    
32.             Do Until rs.EOF
    
33.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
34.                     S = Replace(rs("TABLE_NAME").Value, "'", "")
    
35.                     If Right(S, 1) = "$" Then
    
36.                      
    
37.                         Set Rst = cnn.Execute(strSQL & "[" & S & "] & 条件 & ")
    
38.                         If Err.Number = 0 Then
    
39.                             m = m + 1
    
40.                             If m = 1 Then
    
41.                                 For j = 0 To Rst.Fields.Count - 1
    
42.                                     Cells(1, j + 1) = Rst.Fields(j).Name
    
43.                                 Next
    
44.                                 Range("A2").CopyFromRecordset Rst
    
45.                             Else
    
46.                                 Range("A65536").End(xlUp).Offset(1).CopyFromRecordset Rst
    
47.                             End If
    
48.                             Exit Do
    
49.                         Else
    
50.                             Err.Clear
    
51.                         End If
    
52.                     End If
    
53.                 End If
    
54.                 rs.MoveNext
    
55.             Loop
    
56.         End If
    
57.     Next
    
58.     Cells.EntireColumn.AutoFit
    
59.     Rst.Close
    
60.     rs.Close
    
61.     cnn.Close
    
62.     Set cnn = Nothing
    
63.     Set rs = Nothing
    
64.     Set Rst = Nothing
    
65.     Application.ScreenUpdating = True
    
66. End Sub
    

复制代码

张雄友

第4句，37句 ，要怎么修改？

hwc2ycy

1. Sub subProgram(ByVal SQL$, ByVal myPath$, ByVal OutputSheet$, ByVal OutputRange$)    '子程序
   
2.     Dim cnn As Object, Rst As Object, rs As Object
   
3.     Dim strConn As String, strSQL As String
   
4.     Dim i As Integer, j%, Pathstr, s$, t$, sProvider$
   
5.     Pathstr = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="打开Excel文件", MultiSelect:=True)    '选择多个EXCCEL 文件
   
6.     If TypeName(Pathstr) = "Boolean" Then Exit Sub
   
7.     Application.ScreenUpdating = False
   
8.     Select Case Application.Version * 1
   
9.         Case Is <= 11
   
10.             sProvider = "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties =Excel 8.0;Data Source ="
    
11.         Case Is >= 12
    
12.             sProvider = "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source ="
    
13.     End Select
    
14.     Cells.ClearContents
    
15.     'On Error Resume Next
    
16.     myPath = s
    
17.    
    
18.     For i = 1 To UBound(Pathstr)
    
19.         If Pathstr(i) <> ThisWorkbook.FullName Then
    
20.             Set cnn = CreateObject("ADODB.Connection")
    
21.             cnn.Open sProvider & Pathstr(i)
    
22.             Set rs = cnn.OpenSchema(20)
    
23.             Do Until rs.EOF
    
24.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
25.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
26.                     If Right(s, 1) = "$" Then
    
27.                         strSQL = "select 姓名,身份证号 from [" & s & "]"    '把这句去掉就出错了,但是不去掉,就等于说上面“载入数据”这个程序是多余的。
    
28.                         '不知问题出在哪里？？？？？？？？？
    
29.                         On Error Resume Next
    
30.                         Set Rst = cnn.Execute(strSQL)
    
31.                         If Err.Number = 0 Then
    
32.                             m = m + 1
    
33.                             If m = 1 Then
    
34.                                 For j = 0 To Rst.Fields.Count - 1
    
35.                                     Cells(1, j + 1) = Rst.Fields(j).Name
    
36.                                 Next
    
37.                                 Range("A2").CopyFromRecordset Rst
    
38.                             Else
    
39.                                 Range("A65536").End(xlUp).Offset(1).CopyFromRecordset Rst
    
40.                                 Exit Do
    
41.                             End If
    
42.                            
    
43.                         Else
    
44.                             Err.Clear
    
45.                         End If
    
46.                     End If
    
47.                 End If
    
48.                 rs.MoveNext
    
49.             Loop
    
50.         End If
    
51.     Next
    
52.     Cells.EntireColumn.AutoFit
    
53.     Rst.Close
    
54.     rs.Close
    
55.     cnn.Close
    
56.     Set cnn = Nothing
    
57.     Set rs = Nothing
    
58.     Set Rst = Nothing
    
59.     Application.ScreenUpdating = True
    
60. End Sub

复制代码

EXIT DO放错位置了。

张雄友

hwc2ycy 发表于 2014-5-5 21:36
EXIT DO放错位置了。

子程序中还写入SQL语句，就是多此一举了。strSQL = "select 姓名,身份证号 from [" & s & "]" 如果是这样就根本不用调用了。

hwc2ycy

上面的我弄错了，提早跳出了循环，更不对。

1. Sub subProgram(ByVal SQL$, ByVal myPath$, ByVal OutputSheet$, ByVal OutputRange$)    '子程序
   
2.     Dim cnn As Object, Rst As Object, rs As Object
   
3.     Dim strConn As String, strSQL As String
   
4.     Dim i As Integer, j%, Pathstr, s$, t$, sProvider$
   
5.     Pathstr = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="打开Excel文件", MultiSelect:=True)    '选择多个EXCCEL 文件
   
6.     If TypeName(Pathstr) = "Boolean" Then Exit Sub
   
7.     Application.ScreenUpdating = False
   
8.     Select Case Application.Version * 1
   
9.         Case Is <= 11
   
10.             sProvider = "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties =Excel 8.0;Data Source ="
    
11.         Case Is >= 12
    
12.             sProvider = "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source ="
    
13.     End Select
    
14.     Cells.ClearContents
    
15.     'On Error Resume Next
    
16.     myPath = s
    
17.    
    
18.     For i = 1 To UBound(Pathstr)
    
19.         If Pathstr(i) <> ThisWorkbook.FullName Then
    
20.             Set cnn = CreateObject("ADODB.Connection")
    
21.             cnn.Open sProvider & Pathstr(i)
    
22.             Set rs = cnn.OpenSchema(20)
    
23.             Do Until rs.EOF
    
24.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
25.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
26.                     If Right(s, 1) = "$" Then
    
27.                         strSQL = "select 姓名,身份证号 from [" & s & "]"    '把这句去掉就出错了,但是不去掉,就等于说上面“载入数据”这个程序是多余的。
    
28.                         '不知问题出在哪里？？？？？？？？？
    
29.                         On Error Resume Next
    
30.                         Set Rst = cnn.Execute(strSQL)
    
31.                         If Err.Number = 0 Then
    
32.                             m = m + 1
    
33.                             If m = 1 Then
    
34.                                 For j = 0 To Rst.Fields.Count - 1
    
35.                                     Cells(1, j + 1) = Rst.Fields(j).Name
    
36.                                 Next
    
37.                                 Range("A2").CopyFromRecordset Rst
    
38.                             Else
    
39.                                 Range("A65536").End(xlUp).Offset(1).CopyFromRecordset Rst
    
40.                                End If
    
41.                         Else
    
42.                             Err.Clear
    
43.                            End If
    
44.                     End If
    
45.                 End If
    
46.                 rs.MoveNext
    
47.             Loop
    
48.         End If
    
49.     Next
    
50.     Cells.EntireColumn.AutoFit
    
51.     Rst.Close
    
52.     rs.Close
    
53.     cnn.Close
    
54.     Set cnn = Nothing
    
55.     Set rs = Nothing
    
56.     Set Rst = Nothing
    
57.     Application.ScreenUpdating = True
    
58. End Sub

复制代码

hwc2ycy

另外，好像指定的写入工作表，单元格参数还没有用到吧?

张雄友

hwc2ycy 发表于 2014-5-5 21:43
另外，好像指定的写入工作表，单元格参数还没有用到吧?

现在不知道where 语句怎么设置。设置在哪里。

hwc2ycy

strSQL = "select 姓名,身份证号 from [" & s & "]"
在这后面再添加WHERE子句。