killok, \подобный вопрос совсем не редкий, и решений на форуме очень много
Вот один из вариантов, а Вы допилите под себя...
Скрытый текст |
|---|
Поправленный Павлом
'http://www.planetaexcel.ru/forum.php?thread_id=3878
'autor Pavel55
Option Explicit
Sub CollectInfo()
Dim BazaWb As Workbook 'текущая книга (общий файл)
Dim BazaSht As Worksheet 'лист Price-group в общем файле
Dim iTempFileName As String 'имя поочерёдно открываемого файла
Dim iPath As String 'путь к папке, где лежат все файлы
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле в столбце C
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле в столбце C
Dim k As Long, nrToFind As Long, nrIsFind As Range, ccInBasa As Range
Dim strFileName As String, myUsedRange As Range
Dim firstAddress As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlManual
Set BazaWb = ThisWorkbook
Set BazaSht = BazaWb.ActiveSheet
strFileName = BazaSht.Range("D2").Text
iPath = BazaWb.Path & "\"
iTempFileName = BazaSht.Range("D2") & ".xls"
If Dir(iPath$ + iTempFileName) = "" Then
MsgBox "Книга с названием " & iTempFileName & " в папке " & iPath & " отсутствует!", 48, "Ошибка"
Exit Sub
End If
iLastRowBaza = BazaSht.Cells(Rows.Count, 1).End(xlUp).Row
Set myUsedRange = BazaSht.Range("A3:A" & iLastRowBaza)
If iTempFileName <> "" Then
If iTempFileName <> BazaWb.Name Then
With .Workbooks.Open _
(Filename:=iPath & iTempFileName, UpdateLinks:=False) 'открываем заданный файл ТМП
iLastRowTempWb = .ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'расчитываем кол-во строк в открытом
For k = 3 To iLastRowBaza 'начинаем выбирать значения с основного листа
nrToFind = BazaSht.Range("A" & k).Value
'находим заданный номер в файле ТМП
Set nrIsFind = .ActiveSheet.Range("A2:A" & iLastRowTempWb).Find(What:=nrToFind, _
LookIn:=xlFormulas, LookAt:=xlWhole)
If Not nrIsFind Is Nothing Then
If Not IsEmpty(nrIsFind.Offset(0, 1)) Then
Set ccInBasa = myUsedRange.Find(What:=nrToFind, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns)
firstAddress = BazaSht.Range("A" & k).Address
With BazaSht
Do 'цикл поиска номера, т.к. один и тот же номер может встречаться несколько раз
ccInBasa.Offset(0, 3).Value = nrIsFind.Offset(0, 1).Value
Set ccInBasa = myUsedRange.FindNext(ccInBasa) 'продолжаем поиск на том же листе
Loop While ccInBasa.Address <> firstAddress
nrIsFind.Offset(0, 1).ClearContents
End With
End If
Else:
BazaSht.Range("D" & k) = "Не найден!"
'MsgBox "Номер - " & nrToFind & " не найден в файле " & strFileName & ".xls", vbInformation, "Ошибка поиска"
End If
Next k
.Close saveChanges:=True
End With
End If
iTempFileName = Dir
End If
.Calculation = xlAutomatic
.DisplayAlerts = True
.ScreenUpdating = True
End With
MsgBox "Информация собрана из файла " & strFileName & ".xls", vbInformation, "Конец"
End Sub |
