Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Последовательное подстановка, с последующим сохранением в отдельный файл
 
#1
13.10.2021 15:30:22
Добрый день!
Помогите решить задачу.
Суть вопроса в чем,  необходим макрос который будет последовательно подставлять значения из отфильтрованного диапазона листа дог. 246 с ячеек G6:G...., в ячейку другого листа Титул AO6 ( на основании этого изменяться другие привязанные значения на листах), с последующим сохранением всей книги в отдельный файл, находящийся в одной папке, с присвоением нового имени файла взятого из двух соответствующих строк из диапозона G6:G....  и S6:S.... .
 
 
 
#2
13.10.2021 15:35:33
Добрый день.
С чем помочь, что конкретно не получается?
Кому решение нужно - тот пример и рисует.
 
 
 
#3
13.10.2021 15:41:00
Если не сочтете за наглость то написать сам макрос, знаю это чисто поверхностно, и пытался объединить два кода найденные тут, но увы провал, пытался сделать это через запись макроса, тоже не получилось, почему то каждый раз подставляет значения из одной и той же ячейки, хотя при записи выставлял относительные ссылки
 
 
 
#4
13.10.2021 15:50:24
Код
Option Explicit

Sub ПеребратьЗначения()
    Dim y As Long
    Dim arrG As Variant
    Dim arrS As Variant
    With Sheets("дог. 246")
        y = .Cells(.Rows.Count, "G").End(xlUp).Row
        If y = 1 Then y = 2
        arrG = .Range(.Cells(1, "G"), .Cells(y, "G"))
        arrS = .Range(.Cells(1, "S"), .Cells(y, "S"))
    End With
    
    Dim sName As String
    For y = 6 To UBound(arrG, 1)
        Sheets("Титул").Range("AO6").Value = arrG(y, 1)
        Application.CalculateFull
        
        sName = arrG(y, 1) & arrS(y, 1)
        sName = ThisWorkbook.Path & "\" & sName & ".xlsm"
        ActiveWorkbook.SaveCopyAs sName
    Next
End Sub
 
 
 
#5
13.10.2021 15:59:05
Заработал Спасибо!!!! Огромное СПАСИБО!!!! можно вопрос только уточняющий, изменить возможно чтобы он подставлял только те ячейки которые отображены после фильтра?
Изменено: Антон Бруевич - 13.10.2021 16:05:36
 
 
 
#6
13.10.2021 16:23:52
Код
Sub ПеребратьЗначения()
    Dim y As Long
    Dim arrG As Variant
    Dim arrS As Variant
    With Sheets("дог. 246")
        y = .Cells(.Rows.Count, "G").End(xlUp).Row
        If y = 1 Then y = 2
        arrG = .Range(.Cells(1, "G"), .Cells(y, "G"))
        arrS = .Range(.Cells(1, "S"), .Cells(y, "S"))
     
        Dim sName As String
        For y = 6 To UBound(arrG, 1)
            If Not .Rows(y).Hidden Then
                Sheets("Титул").Range("AO6").Value = arrG(y, 1)
                Application.CalculateFull
                 
                sName = arrG(y, 1) & arrS(y, 1)
                sName = ThisWorkbook.Path & "\" & sName & ".xlsm"
                ActiveWorkbook.SaveCopyAs sName
            End If
        Next
    
    End With
End Sub
 
 
 
#7
25.05.2023 14:56:01
Добрый день! В продолжении темы, помоги сделать так чтобы этот код сохранял данные в .pdf, причем с возможностью прописания в коде определенных страниц для сохранения
Sub ПеребратьЗначения()    Dim y As Long
   Dim arrG As Variant
   Dim arrS As Variant
   With Sheets("дог. 246")
       y = .Cells(.Rows.Count, "G").End(xlUp).Row
       If y = 1 Then y = 2
       arrG = .Range(.Cells(1, "G"), .Cells(y, "G"))
       arrS = .Range(.Cells(1, "S"), .Cells(y, "S"))
     
       Dim sName As String
       For y = 6 To UBound(arrG, 1)
           If Not .Rows(y).Hidden Then
               Sheets("Титул").Range("AO6").Value = arrG(y, 1)
               Application.CalculateFull
                 
               sName = arrG(y, 1) & arrS(y, 1)
               sName = ThisWorkbook.Path & "\" & sName & ".xlsm"
               ActiveWorkbook.SaveCopyAs sName
           End If
       Next
   
   End With
End Sub
 
 
 
Страницы: 1
Наверх