Есть несколько файлов в одной папке. в каждом несколько листов.
Задача: в новом файле есть уникальные значения в столбце B. Нужно просмотреть файлы в этой же папке и найти значения из столбца B. Значение может быть в нескольких файлах. Если найдено значение то записать имя найдено файла в столбце I, если найдено во втором файле, то записать имя второго файла в столбец J и тд
На просторах интернета нашел макрос который просматривает значения из столбца А и пишет в столбец B, но пишет только одно имя файла.
Прошу ГУРУ помочь - отредактировать макрос
[vba]
Код
Sub poisk_v() Dim poisk Dim sFolder As String, sFiles As String Dim wB As Workbook, wFromB As Workbook Application.ScreenUpdating = False Application.EnableEvents = False
Set wB = ActiveWorkbook sFolder = wB.Path & "\" sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" If sFiles = wB.Name Then GoTo lop Set wFromB = Workbooks.Open(sFolder & sFiles) With wB.Sheets(1) For Each WhatFind In .Cells(1, 1).Resize(.Cells(Rows.Count, 1).End(xlUp).Row, 1) If IsEmpty(WhatFind.Offset(, 1).Value) Then For Each MySheet In wFromB.Sheets Set result = MySheet.Range("A:D").Find(What:=WhatFind.Value, LookIn:=xlValues, LookAt:= _ xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , SearchFormat:=False) If Not result Is Nothing Then WhatFind.Offset(, 1).Value = sFiles wFromB.Close False GoTo lop End If Next End If Next End With wFromB.Close False lop: sFiles = Dir Loop Application.EnableEvents = True Application.ScreenUpdating = True End Sub
[/vba]
Добрый день!
Нужна помощь в написании/редактировании макроса.
Есть несколько файлов в одной папке. в каждом несколько листов.
Задача: в новом файле есть уникальные значения в столбце B. Нужно просмотреть файлы в этой же папке и найти значения из столбца B. Значение может быть в нескольких файлах. Если найдено значение то записать имя найдено файла в столбце I, если найдено во втором файле, то записать имя второго файла в столбец J и тд
На просторах интернета нашел макрос который просматривает значения из столбца А и пишет в столбец B, но пишет только одно имя файла.
Прошу ГУРУ помочь - отредактировать макрос
[vba]
Код
Sub poisk_v() Dim poisk Dim sFolder As String, sFiles As String Dim wB As Workbook, wFromB As Workbook Application.ScreenUpdating = False Application.EnableEvents = False
Set wB = ActiveWorkbook sFolder = wB.Path & "\" sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" If sFiles = wB.Name Then GoTo lop Set wFromB = Workbooks.Open(sFolder & sFiles) With wB.Sheets(1) For Each WhatFind In .Cells(1, 1).Resize(.Cells(Rows.Count, 1).End(xlUp).Row, 1) If IsEmpty(WhatFind.Offset(, 1).Value) Then For Each MySheet In wFromB.Sheets Set result = MySheet.Range("A:D").Find(What:=WhatFind.Value, LookIn:=xlValues, LookAt:= _ xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , SearchFormat:=False) If Not result Is Nothing Then WhatFind.Offset(, 1).Value = sFiles wFromB.Close False GoTo lop End If Next End If Next End With wFromB.Close False lop: sFiles = Dir Loop Application.EnableEvents = True Application.ScreenUpdating = True End Sub
Здравствуйте. Судя по описанию, примерно так можно
[vba]
Код
Sub poisk_v() Dim poisk Dim sFolder As String, sFiles As String, n As Long Dim wB As Workbook, wFromB As Workbook, WhatFind As Range, MySheet As Worksheet, result As Range Application.ScreenUpdating = False Application.EnableEvents = False
Set wB = ThisWorkbook sFolder = wB.Path & "\" sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" If sFiles <> wB.Name Then Set wFromB = Workbooks.Open(sFolder & sFiles) With wB.Sheets(1) For Each WhatFind In .Cells(1, 2).Resize(.Cells(Rows.Count, 2).End(xlUp).Row, 1) For Each MySheet In wFromB.Sheets Set result = MySheet.Range("B:B").Find(What:=WhatFind.Value, LookIn:=xlValues, LookAt:= _ xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , SearchFormat:=False) If Not result Is Nothing Then n = Application.Max(7, .Cells(WhatFind.Row, .Columns.Count).End(xlToLeft).Column - 1) WhatFind.Offset(, n).Value = sFiles End If Next Next End With wFromB.Close False End If sFiles = Dir Loop Application.EnableEvents = True Application.ScreenUpdating = True End Sub
[/vba]
Здравствуйте. Судя по описанию, примерно так можно
[vba]
Код
Sub poisk_v() Dim poisk Dim sFolder As String, sFiles As String, n As Long Dim wB As Workbook, wFromB As Workbook, WhatFind As Range, MySheet As Worksheet, result As Range Application.ScreenUpdating = False Application.EnableEvents = False
Set wB = ThisWorkbook sFolder = wB.Path & "\" sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" If sFiles <> wB.Name Then Set wFromB = Workbooks.Open(sFolder & sFiles) With wB.Sheets(1) For Each WhatFind In .Cells(1, 2).Resize(.Cells(Rows.Count, 2).End(xlUp).Row, 1) For Each MySheet In wFromB.Sheets Set result = MySheet.Range("B:B").Find(What:=WhatFind.Value, LookIn:=xlValues, LookAt:= _ xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , SearchFormat:=False) If Not result Is Nothing Then n = Application.Max(7, .Cells(WhatFind.Row, .Columns.Count).End(xlToLeft).Column - 1) WhatFind.Offset(, n).Value = sFiles End If Next Next End With wFromB.Close False End If sFiles = Dir Loop Application.EnableEvents = True Application.ScreenUpdating = True End Sub