Макрос для отбора данных

[Hugo121]

Про WHERE не скажу, а вот массив тут совершенно лишний
(как и a(), b(), ii As Long):

With Sheets(2)
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To Lr
s = s & "(`Лист1$`.`лиц счет`=" & i & ")"
's = " & "
Next i

[dyakon88]

почему не скажешь? подскажи пожалуйста!

[Hugo121]

WHERE - это к Евгению...

[dyakon88]

Почему на эту строку ругается? .Refresh BackgroundQuery:=False

Option Explicit
Sub Макрос2()
Dim Lr As Long, i As Long, s As String

' Макрос2 Макрос
'
'
With ActiveSheet.ListObjects.Add(SourceT ype:=0, Source:=Array(Array( _
"ODBC;DSN=Excel Files;DBQ=C:\Documents and Settings\Юзер\Рабочий стол\ексель\excel\пример.xls;Defaul tDir=C:\Documents and Settings\Юз" _
), Array( _
"ер\Рабочий стол\ексель\excel;DriverId=1046;Max BufferSize=2048;PageTimeout=5;") _
), Destination:=Range("$A$1")).QueryTa ble


With Sheets(2)
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To Lr
s = s & "(`Лист1$`.`лиц счет`=" & i & ")"
's = " & "
Next i


.CommandText = Array("SELECT `Лист1$`.`лиц счет`, `Лист1$`.фамилия" & Chr(13) & "" & Chr(10) & "FROM `Лист1$` `Лист1$`" & Chr(13) & "" & Chr(10) & "WHERE ( & s)")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "Таблица_Запрос_из_Excel_Files"
.Refresh BackgroundQuery:=False
End With
End Sub

[masterenergy]

Сообщение от Hugo121

Так:

Option Explicit

Sub otbor()
Dim a(), b(), Lr As Long, i As Long, ii As Long

With Sheets(1)
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
a = .Range("a1:b" & Lr).Value
End With

With Sheets(2)
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
b = .Range("a1:b" & Lr).Value
End With

For i = 1 To UBound(b)
For ii = 1 To UBound(a)
If b(i, 1) = a(ii, 1) Then b(i, 2) = a(ii, 2)
Next ii, i

With Sheets(3)
.Range("a1:b" & UBound(b)).Value = b
End With

End Sub

а если предположим что у нас на втором листе, в первом есть номер которого нет на первом листе, в первом столбце, то тогда этот код выдаёт ошибку в этой строке .Range("a1:b" & UBound(b)).Value = b , пробовал поменять ни чего не получилось! Помогите пожалуйста, сделать так чтобы он переносил этот номер но во второй столбец писал, для примера "Ошибка".

[Hugo121]

Нормально отработал и в таком случае. Но можно и написать:

Option Explicit

Sub otbor()
Dim a(), b(), Lr As Long, i As Long, ii As Long

With Sheets(1)
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
a = .Range("a1:b" & Lr).Value
End With

With Sheets(2)
Lr = .Cells(Rows.Count, 1).End(xlUp).Row
b = .Range("a1:b" & Lr).Value
End With

For i = 1 To UBound(b)
For ii = 1 To UBound(a)
If b(i, 1) = a(ii, 1) Then b(i, 2) = a(ii, 2)
Next ii
If Trim(b(i, 2)) = "" Then b(i, 2) = "Ошибка"
Next i

With Sheets(3)
.Range("a1:b" & UBound(b)).Value = b
End With

End Sub

Хотя тут есть лазейки, например если в первом листе номер будет, но не будет данных, то тоже будет "Ошибка".

[dyakon88]

Подскажите пожалуйста , как написать макрос с помощью запроса:
1. данные находятся на одном файле Excel на первом листе.
2. надо написать макрос, чтобы он скопировал данные с (1.-с одного файла) на другой файл Excel и тоже на первый лист(разницы нет на какой лист...)
3. Данные находятся на одном столбце под названием (лиц счет)

Пробовал делать сам, ошибки постоянно ( не силен в Excel.

[dyakon88]

Что тут еще не хватает, не хочет работать код...

With Windows("пример.xls").Activate
rr = Windows("пример.xls").SheetViews.It em(2).Sheet.Cells.Copy
End With
With Windows("Книга1.xls").Activate
Windows("Книга1.xls").SheetViews.It em(1).Sheet.Cells.Paste
End With

[dyakon88]

Тему можно закрывать, вопросы решены! Благодарю!