Есть несколько файлов Excel защищенных шифрованием разными паролями. Макрос собирает все данные в один файл, но приходится вводить пароль по каждому файлу(файлов много ). Код как написан и как работает, все устраивает. Нужно только дополнить, чтобы пароли сами вводились. Если правильно понимаю, нужно указать список файлов и список паролей к ним. Но в каком виде и где именно указать их в коде не могу разобраться.
[vba]
Код
Sub ЗаполнениеСводнойТаблицы() Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim coll As New Collection, wb As Workbook, sh As Worksheet, newRow As Range Mask = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "*.xls")
Filename = Dir(Mask) While Filename <> "" ' перебираем все файлы в текущей папке If Not Filename Like ThisWorkbook.Name & "*" Then coll.Add Filename Filename = Dir Wend
On Error Resume Next For Each Item In coll Set wb = Workbooks.Open(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, Item), , True) If Not wb Is Nothing Then Set sh = wb.Worksheets(1) LastRow = sh.Range("a65000").End(xlUp).Row If LastRow > 2 Then ' если есть заполненные строки For i = 2 To LastRow Set newRow = Me.Range("a65000").End(xlUp).Offset(1) sh.Rows(i).Copy newRow newRow.EntireRow.AutoFit Next i End If wb.Close False End If Next Application.DisplayAlerts = True End Sub
[/vba]
Пример в приложении: файл «1» (пароль= 123) и сводный файл.
Есть несколько файлов Excel защищенных шифрованием разными паролями. Макрос собирает все данные в один файл, но приходится вводить пароль по каждому файлу(файлов много ). Код как написан и как работает, все устраивает. Нужно только дополнить, чтобы пароли сами вводились. Если правильно понимаю, нужно указать список файлов и список паролей к ним. Но в каком виде и где именно указать их в коде не могу разобраться.
[vba]
Код
Sub ЗаполнениеСводнойТаблицы() Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim coll As New Collection, wb As Workbook, sh As Worksheet, newRow As Range Mask = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "*.xls")
Filename = Dir(Mask) While Filename <> "" ' перебираем все файлы в текущей папке If Not Filename Like ThisWorkbook.Name & "*" Then coll.Add Filename Filename = Dir Wend
On Error Resume Next For Each Item In coll Set wb = Workbooks.Open(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, Item), , True) If Not wb Is Nothing Then Set sh = wb.Worksheets(1) LastRow = sh.Range("a65000").End(xlUp).Row If LastRow > 2 Then ' если есть заполненные строки For i = 2 To LastRow Set newRow = Me.Range("a65000").End(xlUp).Offset(1) sh.Rows(i).Copy newRow newRow.EntireRow.AutoFit Next i End If wb.Close False End If Next Application.DisplayAlerts = True End Sub
[/vba]
Пример в приложении: файл «1» (пароль= 123) и сводный файл.Economist61
Я ж не про Excel, а про оформление поста в соответствии с Правилами форума. Нажмите кнопку Правка под своим первым постом, выделите код и нажмите кнопку # на панели инструментов, сохраните изменения
Я ж не про Excel, а про оформление поста в соответствии с Правилами форума. Нажмите кнопку Правка под своим первым постом, выделите код и нажмите кнопку # на панели инструментов, сохраните измененияPelena
"Черт возьми, Холмс! Но как??!!" Ю-money 41001765434816
Помогли на другом сайте. Кому еще понадобится пишу код.
[vba]
Код
Sub ЗаполнениеСводнойТаблицы() Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim wb As Workbook, sh As Worksheet, newRow As Range Dim Files() Dim LastRow As Long, i As Long, ii As Long
Call Список_файлов_и_паролей(Files)
On Error Resume Next For i = 1 To UBound(Files) Set wb = Workbooks.Open(Filename:=Files(i, 1), ReadOnly:=True, password:=Files(i, 2)) If Not wb Is Nothing Then Set sh = wb.Worksheets(1) LastRow = sh.Range("a65000").End(xlUp).Row If LastRow > 2 Then ' если есть заполненные строки For ii = 2 To LastRow Set newRow = Me.Range("a65000").End(xlUp).Offset(1) sh.Rows(ii).Copy newRow newRow.EntireRow.AutoFit Next ii End If wb.Close False End If Next i Application.DisplayAlerts = True End Sub
Private Sub Список_файлов_и_паролей(Files()) 'в скобках, после первого "To" укажите, сколько файлов. сейчас указано 3 ReDim Files(1 To 3, 1 To 2) Files(1, 1) = ThisWorkbook.Path & "\" & "файл1.xls": Files(1, 2) = "123" Files(2, 1) = ThisWorkbook.Path & "\" & "файл2.xls": Files(2, 2) = "456" Files(3, 1) = ThisWorkbook.Path & "\" & "файл3.xls": Files(3, 2) = "789" 'здесь допишите для остальных файлов End Sub
[/vba]
Помогли на другом сайте. Кому еще понадобится пишу код.
[vba]
Код
Sub ЗаполнениеСводнойТаблицы() Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim wb As Workbook, sh As Worksheet, newRow As Range Dim Files() Dim LastRow As Long, i As Long, ii As Long
Call Список_файлов_и_паролей(Files)
On Error Resume Next For i = 1 To UBound(Files) Set wb = Workbooks.Open(Filename:=Files(i, 1), ReadOnly:=True, password:=Files(i, 2)) If Not wb Is Nothing Then Set sh = wb.Worksheets(1) LastRow = sh.Range("a65000").End(xlUp).Row If LastRow > 2 Then ' если есть заполненные строки For ii = 2 To LastRow Set newRow = Me.Range("a65000").End(xlUp).Offset(1) sh.Rows(ii).Copy newRow newRow.EntireRow.AutoFit Next ii End If wb.Close False End If Next i Application.DisplayAlerts = True End Sub
Private Sub Список_файлов_и_паролей(Files()) 'в скобках, после первого "To" укажите, сколько файлов. сейчас указано 3 ReDim Files(1 To 3, 1 To 2) Files(1, 1) = ThisWorkbook.Path & "\" & "файл1.xls": Files(1, 2) = "123" Files(2, 1) = ThisWorkbook.Path & "\" & "файл2.xls": Files(2, 2) = "456" Files(3, 1) = ThisWorkbook.Path & "\" & "файл3.xls": Files(3, 2) = "789" 'здесь допишите для остальных файлов End Sub