Страницы: 1
RSS
Создание автоматически заполняемого документа
 
Господа, подскажите, пожалуйста.
Реально ли сделать следующее:
Необходимо в Книге создать лист, в котором будет храниться информация и лист для копирования
Из них нужно, чтобы на 1 листе можно было указать количество N, после чего должно создаться N копий второго листа.
Помимо этого необходимо, чтобы на каждый лист можно было присвоить значения из диапазона (A1:AN) в определенную ячейку каждого листа (A1 первого листа должно отобразиться в B3 первой созданной копии листа 2, А2 в ячейке В3 второй созданной копии листа 2, ... , АN в ячейке В3 N-ной копии листа 2)
 
 
Цитата
написал:
Реально ли сделать следующее
Реально.
 
Цитата
написал:
Реально.
Можно ли это сделать с помощью формул или нужно писать код ?
 

Цитата
написал:
Можно ли это сделать с помощью формул или нужно писать код ?
Встроенные формулы точно не будут копировать листы. Вменить ячейке B3 формулу в зависимости от имени листа можно.

Код
Sub createLists()
    Dim aWB As Workbook, aST As Worksheet, cST As Worksheet
    
    Set aWB = ThisWorkbook
    Set aST = aWB.ActiveSheet
    
    For i = aST.Cells(1, aST.Columns.Count).End(xlToLeft).Column To 1 Step -1
        aWB.Sheets("Лист2").Copy After:=aST
        Set cST = aWB.ActiveSheet
        cST.Name = "a_" & i
        cST.Cells(3, 2).Value = aST.Cells(1, i).Value
    Next
    aST.Activate
End Sub

Изменено: Nart1ny - 13.01.2025 17:01:48
 
Nart1ny, Спасибо большое!
 
Nart1ny, еще вопрос: данный макрос создает листы при наличии значений в 1 строке
Если у меня будет лист с заимствованием данных из другого листа, то пустые ячейки он отображает как "0", можно ли как-то сделать, чтобы он не реагировал на нулевое значение?
заимствование идет по формуле =СМЕЩ(Info!$H$1;0;СТРОКА(A1)+(СТОЛБЕЦ(A1)-1)*8+1)
 
Также если заимствовать значения через функцию ЕСЛИ и получать значение "", то макрос все равно реагирует на значение
 
Цитата
GriBosse написал: Если у меня будет ...Также если заимствовать...
Вы бы приложили файл-пример(Excel). Как есть - Как надо. Со всеми возможными если
Согласие есть продукт при полном непротивлении сторон
 
Nart1ny, А Вам бы поправить отображаемое имя. Спасибо
Цитата
3. Запрещено
...
  3.2. Использовать в сообщениях, подписях и логинах на форумах нецензурную лексику, текст с пЕреМеНнЫм регистром или бессмысленным набором символов, заменять буквы другими символами.
Согласие есть продукт при полном непротивлении сторон
 
Нужно чтобы с листа info данные переносились на лист infoVTP в таком формате: 9-16 столбцы листа info друг под другом в столбце 1 листа infoVTP, 17-24 во второй столбец, 25-32 в третий и тд, чтобы создать макрос по примеру уже имеющегося в документе (кнопка заполнить ведомость материалов)
 
В примере макрос создаёт новые листы. В сообщении #10 данные переносятся на один конкретный лист.
Лучше, конечно, внятно объяснить, что нужно.
 
существующий макрос создает листы в количестве заполненных 1-ых ячеек стобцов и заполняет их данными с листа info
необходимо перенести данные с листа info на лист infoVTP в следующем виде: 9-16 столбцы листа info друг под другом в столбце 1 листа infoVTP, 17-24 во второй столбец, 25-32 в третий и тд
В таком случае можно будет создать макрос подобный созданному для автосоздания и заполнения листов с информацией из листа infoVTP
В чем загвоздка: при переносе информации с листа на лист посредством формул макрос видит, что ячейка не пустая и создает для нее лист, что при нулевом/пустом значении ячейки делать не следует

надеюсь я смог объяснить свой ход мыслей
 
Код
Option Explicit

Sub ПеренестиVTP()
    FillSheet Sheets("infoVTP")
End Sub

Private Sub FillSheet(targetSheet As Worksheet)
    Dim vRange As Variant, targetRange As Range
    Set targetRange = targetSheet.Cells(1, 1)
    
    For Each vRange In Array("J1:Q3", "J28:Q29", "J51:Q54")
        GetGromSourceRange Sheets("Info").Range(vRange), targetRange
    Next
End Sub

Private Sub GetGromSourceRange(sourceRange As Range, targetRange As Range)
    Dim arr As Variant, brr As Variant, crr As Variant
    ReDim crr(0 To 0)
    
    Do
        If WorksheetFunction.CountA(sourceRange) = 0 Then Exit Do
        arr = sourceRange.Value
        brr = GetBrr(arr)
        ReDim Preserve crr(LBound(crr) To UBound(crr) + 1)
        crr(UBound(crr)) = brr
        
        Set sourceRange = sourceRange.Offset(0, sourceRange.Columns.Count)
        DoEvents
    Loop
    If UBound(crr) = 0 Then Exit Sub
    
    arr = GetTwoDimArray(crr)
    targetRange.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).NumberFormat = "@"
    targetRange.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Set targetRange = targetRange.Offset(UBound(arr, 1))
End Sub

Private Function GetTwoDimArray(crr As Variant) As Variant
    Dim arr As Variant
    ReDim arr(1 To UBound(crr(1), 1), 1 To UBound(crr))
    Dim ya As Long, xa As Long
    For xa = 1 To UBound(arr, 2)
        For ya = 1 To UBound(arr, 1)
            arr(ya, xa) = crr(xa)(ya)
        Next
    Next
    GetTwoDimArray = arr
End Function

Private Function GetBrr(arr As Variant) As Variant
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1) * UBound(arr, 2))
    
    Dim ya As Long, xa As Long, yb As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            yb = yb + 1
            brr(yb) = arr(ya, xa)
        Next
    Next
    GetBrr = brr
End Function
 
МатросНаЗебре, Спасибо!
Страницы: 1
Наверх