Здравствуйте! Помогите, пожалуйста. Есть большой список файлов, защищенных паролем. В книгу необходимо собрать макросом листы из этих файлов. Так как наименование файлов и листов меняется, то данные собраны в таблице.
У меня бюджетное медицинское учреждение. Установить какое приложение просто так не удастся, нет прав администратора. Может кто-нибудь поможет с макросом. Очень срочно нужно.
в примере - имя файла - C:\Users\Documents\2 это больше похоже на имя папки, к тому же там же Имя книги =1. Имя файла нужно с расширением
Цитата
yelena321 написал: собрать макросом листы из этих файлов
и получить книгу с большим количеством листов? Если Вы знаете, что дальше делать с этими листами, хорошо, но скорее всего потом будут вопросы что-то типа как собрать все на один лист, или как посчитать во всем листам что-то по условию
С такими данными собрать не получится. Что за таблицы какие куда сколько столбцов одинаковое ли количество и многое многое другое.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
вариант. Скопирует все листы со всех указанных книг в книгу со списком.
Код
Sub sbor()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet, wsh As Worksheet, wb As Workbook
Set sh = ActiveSheet
i = 3
Do While sh.Cells(i, 1).Value <> ""
pth = sh.Cells(i, 1).Value & "\" & sh.Cells(i, 3).Value
Set wb = Workbooks.Open(pth, , , , sh.Cells(i, 2).Value)
For Each wsh In wb.Worksheets
wsh.Copy after:=sh
Next
wb.Close 0
i = i + 1
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Общий макрос переноса листов из всех файлов Excel одной папки в книгу с макросом.
Код
Sub test()
' ----------------------------------
Dim sht As Worksheet
Dim fName$, iPath$, ibook As Workbook
' ----------------------------------
With Application
.ScreenUpdating = False: .DisplayAlerts = False
End With
Set ibook = ThisWorkbook
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then iPath = .SelectedItems(1) Else Exit Sub
End With
fName = Dir(iPath & Application.PathSeparator & "*.xls*")
Do Until fName = ""
With GetObject(iPath & Application.PathSeparator & fName)
For Each sht In .Worksheets
sht.Copy after:=ibook.Worksheets(ibook.Sheets.Count)
Next sht
.Close False
End With
fName = Dir
Loop
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
End Sub
Sub sbor()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet, wb As Workbook
Set sh = ActiveSheet
i = 3
Do While sh.Cells(i, 1).Value <> ""
pth = sh.Cells(i, 1).Value & "\" & sh.Cells(i, 3).Value
Set wb = Workbooks.Open(pth, , , , sh.Cells(i, 2).Value)
wb.Worksheets(sh.cells(i,4).value).Copy after:=sh
wb.Close 0
i = i + 1
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
От тут как-то и я в свое время не разобрался, да так руки и не дошли, если имя листа "1" как объяснить экселю в vba что это имя, а не индекс..) Мысль пришла, может не Value, а cells(i, 4).Text использовать?
Sub sbor()
' -----------------------------------
Dim sht As Worksheet, book As Workbook
Dim fName$, iPath$, lRow&, iPassword, shtname$
' -----------------------------------
With Application
.ScreenUpdating = False: .DisplayAlerts = False
End With
Set sht = ThisWorkbook.Worksheets("Лист1")
With sht
lRow = .Range("a" & .Rows.Count).End(xlUp).Row
For i = 3 To lRow
iPath = .Range("a" & i).Value & Application.PathSeparator & .Range("c" & i)
iPassword = .Range("b" & i).Value
shtname = .Range("d" & i).Value
Set book = Workbooks.Open(iPath, Password:=iPassword)
book.Worksheets(shtname).Copy after:=sht
book.Close False
Next i
End With
With Application
.ScreenUpdating =True: .DisplayAlerts = True
End With
End Sub
yelena321, с Вашим изменением имени листа с "1" на "Август" должно и так работать. Если в 10-й строке заменить Value на Text будет работать и с именем листа "1"