工作中自己写的代码
Public Sub ADOTest2() Dim cnn As New ADODB.Connection Dim rs As New ADODB.Recordset Dim strCnn As String Dim i As Long, ii As Long, iii As Long, ppi As Integer, pi As Integer Dim arr1(), arr2(), arr() Dim text As String Set Sheet = ActiveWorkbook.Worksheets(1) strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & ThisWorkbook.Path & "\db.mdb;" cnn.Open strCnn Dim sfzh As String sfzh = Sheet.Cells(4, 19) '从第四行开始 Do If (sfzh <> "212433197805070811") Then ReDim Preserve arr(1 To 23, 1 To ii + 1) For iii = 1 To 22 arr(iii, ii + 1) = Sheet.Cells(4 + ii, 2 + iii).Value Next arr(23, ii + 1) = ActiveWorkbook.FullName ssql = "Select * From db where 增值税登记号= '" & sfzh & "'" '搜索物资表 rs.Open ssql, cnn, adOpenForwardOnly, adLockReadOnly If rs.EOF Then rs.Close ssql = "Select * From cw where 增值税登记号= '" & sfzh & "'" '搜索财务表看是否存在 rs.Open ssql, cnn, adOpenForwardOnly, adLockReadOnly If (rs.EOF) Then '填入物资模板表 pi = pi + 1 ReDim Preserve arr1(1 To 29, 1 To pi) For iii = 1 To 22 arr1(iii, pi) = Sheet.Cells(4 + ii, 2 + iii).Value Next arr1(28, pi) = "物资和财务表中,都没有,填入物资模板表" rs.Close ssql = "Select * From gwgys_1 where 税号= '" & sfzh & "'" rs.Open ssql, cnn, adOpenForwardOnly, adLockReadOnly If (Not rs.EOF) Then arr1(23, pi) = rs.Fields(0).Value If (arr1(1, pi) = rs.Fields(1).Value) Then arr1(24, pi) = "" Else arr1(24, pi) = rs.Fields(1).Value End If If (arr1(4, pi) = rs.Fields("工商登记号").Value) Then arr1(25, pi) = "" Else arr1(25, pi) = rs.Fields("工商登记号").Value End If If (arr1(5, pi) = rs.Fields("组织机构代码").Value) Then arr1(26, pi) = "" Else arr1(26, pi) = rs.Fields("组织机构代码").Value End If If (arr1(17, pi) = rs.Fields("税号").Value) Then arr1(27, pi) = "" Else arr1(27, pi) = rs.Fields("税号").Value End If End If Else '填入财务模板表 ppi = ppi + 1 ReDim Preserve arr2(1 To 29, 1 To ppi) For iii = 2 To 23 arr2(iii, ppi) = Sheet.Cells(4 + ii, 1 + iii).Value Next text = arr2(2, ppi) arr2(29, ppi) = "物资中没有,财务表中有,填入财务模板表" arr2(1, ppi) = rs.Fields(0).Value rs.Close ssql = "Select * From gwgys_1 where 税号= '" & sfzh & "'" rs.Open ssql, cnn, adOpenForwardOnly, adLockReadOnly If (Not rs.EOF) Then arr2(24, ppi) = rs.Fields(0).Value If (arr2(2, ppi) = rs.Fields(1).Value) Then arr2(25, ppi) = "" Else arr2(25, ppi) = rs.Fields(1).Value End If If (arr2(5, ppi) = rs.Fields("工商登记号").Value) Then arr2(26, ppi) = "" Else arr2(26, ppi) = rs.Fields("工商登记号").Value End If If (arr2(6, ppi) = rs.Fields("组织机构代码").Value) Then arr2(27, ppi) = "" Else arr2(27, ppi) = rs.Fields("组织机构代码").Value End If If (arr2(18, ppi) = rs.Fields("税号").Value) Then arr2(28, ppi) = "" Else arr2(28, ppi) = rs.Fields("税号").Value End If End If End If End If rs.Close End If ii = ii + 1 sfzh = Sheet.Cells(4 + ii, 19) '注意这里的单元格是被查询的表,默认都是物资表,故不用管财务表 Loop While sfzh <> "" cnn.Close '有四处是test.xls Dim x As Integer, page As Integer page = 1 For x = 1 To Workbooks.Count If Workbooks(x).Name = "test.xls" Then Exit For End If Next If (x = Workbooks.Count + 1) Then Workbooks.Open "E:\供应商收集\供应商v2.0\营销部\test.xls" End If On Error GoTo err Workbooks("test.xls").Sheets(3).Range("D65536").End(xlUp).Offset(1, -1).Resize(ii, 23) = WorksheetFunction.Transpose(arr) Workbooks("test.xls").Sheets(1).Range("C65536").End(xlUp).Offset(1, 0).Resize(pi, 25) = WorksheetFunction.Transpose(arr1) '最后两个单元格是受保护的,原来是27 Workbooks("test.xls").Sheets(2).Range("D65536").End(xlUp).Offset(1, -1).Resize(ppi, 26) = WorksheetFunction.Transpose(arr2) '最后两个单元格时受保护的,原来是28err: If (err.Number = 5) Then Resume Next End If ' Workbooks("test.xls").Close True End Sub