Здравствуйте! Возможно ли автоматизировать процесс поиска целым списком фамилий (более 200) с указанием папки с файлами, в которых множество фамилий? Найдя фамилию нужно вычислить время (столбец M и J), используя формулу =(M-J)+(M<J). Результат попадает на отдельный лист. В примере форма для заполнения и папка (2018.10) с файлами (год.мес.день), в которых нужно найти фамилии из списка.
Здравствуйте! Возможно ли автоматизировать процесс поиска целым списком фамилий (более 200) с указанием папки с файлами, в которых множество фамилий? Найдя фамилию нужно вычислить время (столбец M и J), используя формулу =(M-J)+(M<J). Результат попадает на отдельный лист. В примере форма для заполнения и папка (2018.10) с файлами (год.мес.день), в которых нужно найти фамилии из списка.stria
Здравствуйте. Выполнимая, но не очень интересная) Вы хотя бы начните что-то делать. Вот, например, здесь есть готовое решение, как перебрать все файлы в папке. А уже, как найти нужную фамилию, кто-нибудь подскажет
Здравствуйте. Выполнимая, но не очень интересная) Вы хотя бы начните что-то делать. Вот, например, здесь есть готовое решение, как перебрать все файлы в папке. А уже, как найти нужную фамилию, кто-нибудь подскажетPelena
"Черт возьми, Холмс! Но как??!!" Ю-money 41001765434816
Pelena, Спасибо, но там не нашел что то подобное. Может подскажете с чего начать? Есть готовый макрос для поиска одного значения, но как сделать поиск списком?
Pelena, Спасибо, но там не нашел что то подобное. Может подскажете с чего начать? Есть готовый макрос для поиска одного значения, но как сделать поиск списком?stria
Непонятно что делать, когда найдено несколько строк с фимилией Короче вот примерный (непроверенный!!!)текст макроса (основное взять по ссылке Лены) нахождения ФИО. Что дальше - не знаю [vba]
Код
Sub Get_All_File_from_Folder() Dim sFolder As String, sFiles As String r0_ = 3 n_ = Cells(Rows.Count, 1).End(3).Row - r0_ + 1 ar = Cells(r0_, 1).Resize(n_, 32) sFolder = "Здесь/полный путь/к/папке с файлами/" Application.ScreenUpdating = False sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" Workbooks.Open sFolder & sFiles With ActiveWorkbook With .Sheets(1) For i = 1 To n_ r_ = .Columns("R:R").Find(What:=ar(i, 1), After:=ActiveCell, LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Row ' это строка с найденной фамилией 'что делать дальще - не знаю Next i End With .Close False End With sFiles = Dir Loop Application.ScreenUpdating = True End Sub
[/vba]
Непонятно что делать, когда найдено несколько строк с фимилией Короче вот примерный (непроверенный!!!)текст макроса (основное взять по ссылке Лены) нахождения ФИО. Что дальше - не знаю [vba]
Код
Sub Get_All_File_from_Folder() Dim sFolder As String, sFiles As String r0_ = 3 n_ = Cells(Rows.Count, 1).End(3).Row - r0_ + 1 ar = Cells(r0_, 1).Resize(n_, 32) sFolder = "Здесь/полный путь/к/папке с файлами/" Application.ScreenUpdating = False sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" Workbooks.Open sFolder & sFiles With ActiveWorkbook With .Sheets(1) For i = 1 To n_ r_ = .Columns("R:R").Find(What:=ar(i, 1), After:=ActiveCell, LookIn:=xlFormulas _ , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Row ' это строка с найденной фамилией 'что делать дальще - не знаю Next i End With .Close False End With sFiles = Dir Loop Application.ScreenUpdating = True End Sub
Sub Zagruzka() Dim sFolder As String, sFiles As String r0_ = 3 n_ = Cells(Rows.Count, 1).End(3).Row - r0_ + 1 Cells(r0_, 2).Resize(n_, 31).ClearContents ar = Cells(r0_, 1).Resize(n_, 32) sFolder = "D:\Стереть\2018.10\" ' здесь напишите свой путь st1_ = 10 st2_ = 13 st3_ = 18 Application.ScreenUpdating = False sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" Workbooks.Open sFolder & sFiles With ActiveWorkbook With .Sheets(1) rf_ = .Cells(.Rows.Count, st3_).End(3).Row If rf_ <> 1 Then ar1 = .Cells(1, st1_).Resize(rf_).Value ar2 = .Cells(1, st2_).Resize(rf_).Value ar3 = .Cells(1, st3_).Resize(rf_).Value den_ = Left(Right(.Cells(1), 10), 2) + 1 For i = 1 To n_ raz_ = 0 For j = 1 To rf_ If InStr(ar3(j, 1), ar(i, 1)) Then dob_ = 0 If ar2(j, 1) < ar1(j, 1) Then dob_ = 1 End If ar(i, den_) = ar(i, den_) + ar2(j, 1) - ar1(j, 1) + dob_ End If Next j Next i End If End With .Close False End With sFiles = Dir Loop Cells(r0_, 1).Resize(n_, 32) = ar Application.ScreenUpdating = True End Sub
[/vba]
Проверяйте
[vba]
Код
Sub Zagruzka() Dim sFolder As String, sFiles As String r0_ = 3 n_ = Cells(Rows.Count, 1).End(3).Row - r0_ + 1 Cells(r0_, 2).Resize(n_, 31).ClearContents ar = Cells(r0_, 1).Resize(n_, 32) sFolder = "D:\Стереть\2018.10\" ' здесь напишите свой путь st1_ = 10 st2_ = 13 st3_ = 18 Application.ScreenUpdating = False sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" Workbooks.Open sFolder & sFiles With ActiveWorkbook With .Sheets(1) rf_ = .Cells(.Rows.Count, st3_).End(3).Row If rf_ <> 1 Then ar1 = .Cells(1, st1_).Resize(rf_).Value ar2 = .Cells(1, st2_).Resize(rf_).Value ar3 = .Cells(1, st3_).Resize(rf_).Value den_ = Left(Right(.Cells(1), 10), 2) + 1 For i = 1 To n_ raz_ = 0 For j = 1 To rf_ If InStr(ar3(j, 1), ar(i, 1)) Then dob_ = 0 If ar2(j, 1) < ar1(j, 1) Then dob_ = 1 End If ar(i, den_) = ar(i, den_) + ar2(j, 1) - ar1(j, 1) + dob_ End If Next j Next i End If End With .Close False End With sFiles = Dir Loop Cells(r0_, 1).Resize(n_, 32) = ar Application.ScreenUpdating = True End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
.
