Developing.ru

Старнно, сделал так:
where (left(trim(ucase(sotr.ФИО)), instr(trim(ucase(sotr.ФИО))+' ', ' ')-1)

и все заработало.
Всем спасибо. Тема закрыта.

Спасибо большое, совсем забыл про эту функцию.
Сходу возник второй вопрос, если первый запрос отрабатывает отлично, то почему во втром, если написать where UCASE(left(trim(sotr.ФИО), instr(trim(sotr.ФИО)+' ', ' ')-1) like
то выводятся все данные, словно условия нету вообще.

" where ucase(people.[фамилия]) like '" & "ИВАНОВ" & "'"

зы.
я для проверки вставил константой фамилию

При всем уважении, мне кажется эта тема больше подходит для VBA&Excel

Может не все сказал, что нужно. Не стесняйтесь спрашивайте. Просто уже давно бьюсь над этой ерундой.

Точная ошибка по последнему посту
Method "Execute" of object "_Connection" failed

Если не понятно, то все чего я хочу добиться это чтобы в запросе секвел при условии where оба значения были прописными буквами.

Еще есть аткой момент

Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Intersect(Range("B1"), Target) Is Nothing) Then
Target.Value = UCase(Target.Value) ' если есть эта строка почему-то вылетает ошибка в сабе Sopostavlenie
Sopostavlenie
End If

Вообщем без аппера все работает.

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

sSQL1 = "SELECT * From [Люди$A2:E25000] as people" + _
" where (upper(people.фамилия ) like ('" & ActiveSheet.Range("B1").Value & "'))"

Я бы с удовольствием скинул всю книгу рабочую, но она сильно большая)
сейчас напишу листинг.
Дело еще в том, что судя по провайдерам видно, что там не только дбейс, но и Extended Properties=""Excel 8.0.
Помнится раньше я на делфи через адо подключался к дбейсу и вроде аппер работал нормально. А если их vba экзелевского, то выдает ошибку типа неопределенная функция uper