heisnod » 25 ноя 2008, 16:43
Public Sub Sopostavlenie()
Rows("4:5000").ClearContents
Dim conn1, conn2, conn3, conn4 As New ADODB.Connection
Dim rs1, rs2, rs3, rs4 As New ADODB.Recordset
Dim str_conn, connDBF As String
Dim sSQL1, ssql2, ssql3, ssql4 As String
Set conn1 = New ADODB.Connection
Set conn2 = New ADODB.Connection
Set conn3 = New ADODB.Connection
Set rs1 = New ADODB.Recordset
Set rs2 = New ADODB.Recordset
Set rs3 = New ADODB.Recordset
str_conn = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" + ThisWorkbook.Path + "\" + ThisWorkbook.Name + ";" _
& "Extended Properties=""Excel 8.0;HDR=Yes"";"
connDBF = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + ThisWorkbook.Path + "\;Extended Properties=dBase IV;mode=Read"
On Error Resume Next
conn1.Open str_conn
On Error GoTo 0
If conn1.State <> 1 Then
MsgBox str_conn
Exit Sub
End If
conn2.Open str_conn
On Error GoTo 0
If conn2.State <> 1 Then
MsgBox str_conn
Exit Sub
End If
conn3.Open connDBF
On Error GoTo 0
If conn3.State <> 1 Then
MsgBox str_conn
Exit Sub
End If
rs1.ActiveConnection = conn1
rs2.ActiveConnection = conn2
rs3.ActiveConnection = conn3
'Сопоставление- по фамилии. Сравнение по первому слову в строке
sSQL1 = "SELECT * From [Люди$A2:E25000] as people" + _
" where ((people.фамилия ) like ('" & ActiveSheet.Range("B1").Value & "'))"
' COLLATE PXW_CYRL
ssql2 = "SELECT * From [Сотрудники$A3:I3400] as sotr" + _
" where (left(trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' ')-1) like '" & ActiveSheet.Range("B1").Value & "') " ' + _
' "and (SUBSTRING (trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' '), ') )='" & ActiveSheet.Range("B2").Value & "')"
ssql3 = "SELECT * From (select * from g where not isnull(fio)) as gai" + _
" where (left(trim(gai.fio), instr(trim(gai.fio)+' ', ' ')-1) like ('" & ActiveSheet.Range("B1").Value & "')) "
ssql5 = "SELECT * From (select * from [СтараяПочта$A5:C500] where not isnull(ответственный)) as emails" + _
" where ((left(trim(emails.ответственный), instr(trim(emails.ответственный)+' ', ' ')-1)='" & ActiveSheet.Range("B1").Value & "')"
' sSQL = "SELECT * From [Люди$A2:E25000] as people,[Сотрудники$A3:I3400] as sotr, (select * from [СтараяПочта$A5:C500] where not isnull(ответственный)) as emails" + _
' " where (left(trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' ')-1)=left(trim(emails.ответственный), instr(trim(emails.ответственный)+' ', ' ')-1)) and (left(trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' ')-1)=people.фамилия) and(people.фамилия='" & ActiveSheet.Range("B1").Value & "')"
With rs1
.CursorType = adOpenStatic
.LockType = adLockReadOnly
End With
Set rs1 = conn1.Execute(sSQL1)
ThisWorkbook.Sheets("Сопоставление").Range("A4").CopyFromRecordset rs1
i = 0
If rs1.BOF = False Then rs1.MoveFirst
While Not rs1.EOF
i = i + 1
rs1.MoveNext
Wend
With rs2
.CursorType = adOpenStatic
.LockType = adLockReadOnly
End With
Set rs2 = conn2.Execute(ssql2)
ThisWorkbook.Sheets("Сопоставление").Range("A" & (4 + 4 + i)).CopyFromRecordset rs2
'ThisWorkbook.Sheets("Сопоставление").Range("A20").CopyFromRecordset rs2
If rs2.BOF = False Then rs2.MoveFirst
While Not rs2.EOF
i = i + 1
rs2.MoveNext
Wend
With rs3
.CursorType = adOpenStatic
.LockType = adLockReadOnly
End With
Set rs3 = conn3.Execute(ssql3)
ThisWorkbook.Sheets("Сопоставление").Range("A" & (4 + 6 + i)).CopyFromRecordset rs3
'ThisWorkbook.Sheets("Сопоставление").Range("A20").CopyFromRecordset rs2
If rs3.BOF = False Then rs3.MoveFirst
While Not rs3.EOF
i = i + 1
rs3.MoveNext
Wend
rs1.Close
rs2.Close
rs3.Close
conn1.Close
conn2.Close
conn3.Close
Set conn1 = Nothing
Set conn2 = Nothing
Set conn3 = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
Set rs3 = Nothing
End Sub
Public Sub Sopostavlenie()
Rows("4:5000").ClearContents
Dim conn1, conn2, conn3, conn4 As New ADODB.Connection
Dim rs1, rs2, rs3, rs4 As New ADODB.Recordset
Dim str_conn, connDBF As String
Dim sSQL1, ssql2, ssql3, ssql4 As String
Set conn1 = New ADODB.Connection
Set conn2 = New ADODB.Connection
Set conn3 = New ADODB.Connection
Set rs1 = New ADODB.Recordset
Set rs2 = New ADODB.Recordset
Set rs3 = New ADODB.Recordset
str_conn = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" + ThisWorkbook.Path + "\" + ThisWorkbook.Name + ";" _
& "Extended Properties=""Excel 8.0;HDR=Yes"";"
connDBF = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + ThisWorkbook.Path + "\;Extended Properties=dBase IV;mode=Read"
On Error Resume Next
conn1.Open str_conn
On Error GoTo 0
If conn1.State <> 1 Then
MsgBox str_conn
Exit Sub
End If
conn2.Open str_conn
On Error GoTo 0
If conn2.State <> 1 Then
MsgBox str_conn
Exit Sub
End If
conn3.Open connDBF
On Error GoTo 0
If conn3.State <> 1 Then
MsgBox str_conn
Exit Sub
End If
rs1.ActiveConnection = conn1
rs2.ActiveConnection = conn2
rs3.ActiveConnection = conn3
'Сопоставление- по фамилии. Сравнение по первому слову в строке
sSQL1 = "SELECT * From [Люди$A2:E25000] as people" + _
" where ((people.фамилия ) like ('" & ActiveSheet.Range("B1").Value & "'))"
' COLLATE PXW_CYRL
ssql2 = "SELECT * From [Сотрудники$A3:I3400] as sotr" + _
" where (left(trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' ')-1) like '" & ActiveSheet.Range("B1").Value & "') " ' + _
' "and (SUBSTRING (trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' '), ') )='" & ActiveSheet.Range("B2").Value & "')"
ssql3 = "SELECT * From (select * from g where not isnull(fio)) as gai" + _
" where (left(trim(gai.fio), instr(trim(gai.fio)+' ', ' ')-1) like ('" & ActiveSheet.Range("B1").Value & "')) "
ssql5 = "SELECT * From (select * from [СтараяПочта$A5:C500] where not isnull(ответственный)) as emails" + _
" where ((left(trim(emails.ответственный), instr(trim(emails.ответственный)+' ', ' ')-1)='" & ActiveSheet.Range("B1").Value & "')"
' sSQL = "SELECT * From [Люди$A2:E25000] as people,[Сотрудники$A3:I3400] as sotr, (select * from [СтараяПочта$A5:C500] where not isnull(ответственный)) as emails" + _
' " where (left(trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' ')-1)=left(trim(emails.ответственный), instr(trim(emails.ответственный)+' ', ' ')-1)) and (left(trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' ')-1)=people.фамилия) and(people.фамилия='" & ActiveSheet.Range("B1").Value & "')"
With rs1
.CursorType = adOpenStatic
.LockType = adLockReadOnly
End With
Set rs1 = conn1.Execute(sSQL1)
ThisWorkbook.Sheets("Сопоставление").Range("A4").CopyFromRecordset rs1
i = 0
If rs1.BOF = False Then rs1.MoveFirst
While Not rs1.EOF
i = i + 1
rs1.MoveNext
Wend
With rs2
.CursorType = adOpenStatic
.LockType = adLockReadOnly
End With
Set rs2 = conn2.Execute(ssql2)
ThisWorkbook.Sheets("Сопоставление").Range("A" & (4 + 4 + i)).CopyFromRecordset rs2
'ThisWorkbook.Sheets("Сопоставление").Range("A20").CopyFromRecordset rs2
If rs2.BOF = False Then rs2.MoveFirst
While Not rs2.EOF
i = i + 1
rs2.MoveNext
Wend
With rs3
.CursorType = adOpenStatic
.LockType = adLockReadOnly
End With
Set rs3 = conn3.Execute(ssql3)
ThisWorkbook.Sheets("Сопоставление").Range("A" & (4 + 6 + i)).CopyFromRecordset rs3
'ThisWorkbook.Sheets("Сопоставление").Range("A20").CopyFromRecordset rs2
If rs3.BOF = False Then rs3.MoveFirst
While Not rs3.EOF
i = i + 1
rs3.MoveNext
Wend
rs1.Close
rs2.Close
rs3.Close
conn1.Close
conn2.Close
conn3.Close
Set conn1 = Nothing
Set conn2 = Nothing
Set conn3 = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
Set rs3 = Nothing
End Sub