Здравствуйте, уважаемы форумчане! Помогите, пожалуйста, решить задачку. есть два файла 1 и 2(прикладываю). нужно из файла 1 запустить скрипт, который откроет в фоне второй файл, по полю ID найдет совпадение и скопирует данные из второго в первый в соответствующие столбцы. Так же есть нюанс, если в поле второго файла в поле title3 написано 456 то необходимо искать и копировать инфу на лист один первого файла. а если что то другое в поле то на лист 2. спасибо за помощь.
Здравствуйте, уважаемы форумчане! Помогите, пожалуйста, решить задачку. есть два файла 1 и 2(прикладываю). нужно из файла 1 запустить скрипт, который откроет в фоне второй файл, по полю ID найдет совпадение и скопирует данные из второго в первый в соответствующие столбцы. Так же есть нюанс, если в поле второго файла в поле title3 написано 456 то необходимо искать и копировать инфу на лист один первого файла. а если что то другое в поле то на лист 2. спасибо за помощь.zaknafein
On Error Resume Next Set wbB = Workbooks.Open(fileBPath, ReadOnly:=True) On Error GoTo 0 If wbB Is Nothing Then MsgBox "Не удалось открыть файл!", vbExclamation: Exit Sub
Dim wsB As Worksheet Set wsB = wbB.Worksheets(1)
For Each cell In wsA1.Range("A2:A" & wsA1.Cells(Rows.Count, 1).End(xlUp).Row) Dim foundCell As Range Set foundCell = wsB.Range("A:A").Find(cell.Value, LookAt:=xlWhole)
If Not foundCell Is Nothing Then Dim targetSheet As Worksheet Set targetSheet = IIf(foundCell.Offset(0, 3).Value = 456, wsA1, wsA2) targetSheet.Cells(cell.Row, 1).Resize(1, 4).Value = foundCell.Resize(1, 4).Value End If
Next cell
wbB.Close False
.Calculation = xlCalculationAutomatic .DisplayAlerts = True .ScreenUpdating = True End With
On Error Resume Next Set wbB = Workbooks.Open(fileBPath, ReadOnly:=True) On Error GoTo 0 If wbB Is Nothing Then MsgBox "Не удалось открыть файл!", vbExclamation: Exit Sub
Dim wsB As Worksheet Set wsB = wbB.Worksheets(1)
For Each cell In wsA1.Range("A2:A" & wsA1.Cells(Rows.Count, 1).End(xlUp).Row) Dim foundCell As Range Set foundCell = wsB.Range("A:A").Find(cell.Value, LookAt:=xlWhole)
If Not foundCell Is Nothing Then Dim targetSheet As Worksheet Set targetSheet = IIf(foundCell.Offset(0, 3).Value = 456, wsA1, wsA2) targetSheet.Cells(cell.Row, 1).Resize(1, 4).Value = foundCell.Resize(1, 4).Value End If
Next cell
wbB.Close False
.Calculation = xlCalculationAutomatic .DisplayAlerts = True .ScreenUpdating = True End With