Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Авто введения пароля при сборе данных с защищ файлов в сводн - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Авто введения пароля при сборе данных с защищ файлов в сводн (Макросы/Sub)
Авто введения пароля при сборе данных с защищ файлов в сводн
Economist61 Дата: Понедельник, 24.04.2017, 16:01 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Есть несколько файлов 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) и сводный файл.
К сообщению приложен файл: 7483256.xlsm (19.0 Kb) · 9196568.xlsx (14.5 Kb)


Сообщение отредактировал Economist61 - Понедельник, 24.04.2017, 18:03
 
Ответить
СообщениеЕсть несколько файлов 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
Дата добавления - 24.04.2017 в 16:01
Pelena Дата: Понедельник, 24.04.2017, 16:45 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19161
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
Economist61, оформите код тегами с помощью кнопки # в режиме правки поста


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеEconomist61, оформите код тегами с помощью кнопки # в режиме правки поста

Автор - Pelena
Дата добавления - 24.04.2017 в 16:45
Economist61 Дата: Понедельник, 24.04.2017, 16:49 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
оформите код тегами с помощью кнопки # в режиме правки поста

В экселе очень слаб все методом тыка. Эти слова мне ничего не говорят.))) Нужно другой код написать? Или поправить то что есть?
 
Ответить
Сообщениеоформите код тегами с помощью кнопки # в режиме правки поста

В экселе очень слаб все методом тыка. Эти слова мне ничего не говорят.))) Нужно другой код написать? Или поправить то что есть?

Автор - Economist61
Дата добавления - 24.04.2017 в 16:49
Pelena Дата: Понедельник, 24.04.2017, 16:51 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 19161
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
Я ж не про Excel, а про оформление поста в соответствии с Правилами форума.
Нажмите кнопку Правка под своим первым постом, выделите код и нажмите кнопку # на панели инструментов, сохраните изменения


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЯ ж не про Excel, а про оформление поста в соответствии с Правилами форума.
Нажмите кнопку Правка под своим первым постом, выделите код и нажмите кнопку # на панели инструментов, сохраните изменения

Автор - Pelena
Дата добавления - 24.04.2017 в 16:51
Economist61 Дата: Вторник, 25.04.2017, 22:21 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 11
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Помогли на другом сайте. Кому еще понадобится пишу код.

[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
[/vba]

Автор - Economist61
Дата добавления - 25.04.2017 в 22:21
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Авто введения пароля при сборе данных с защищ файлов в сводн (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!