Сообщения

Aleksey
Не очень понял о каких ссылках идет речь?
И почему пример без макроса?

Попробуйте такой макрос
Заполнение с 15 строки

Код Выделить Развернуть

Sub Razdel_35()
Dim i As Long
Dim n As Long
Dim begin As Long
Dim Rowbegin As Long
Dim iLen As Long
Dim Kol As Long
Dim temp As String
Dim nStart As Long
 iLen = Len(Range("A2"))
  begin = 1
  Rowbegin = 15
  nStart = 1
  Do
    Kol = 0
    Do
      n = InStr(begin, Range("A2"), ";")
        If n = iLen Then
          Cells(Rowbegin, "A") = Mid(Range("A2"), nStart, n - nStart)
            Exit Sub
        End If
      Kol = Kol + 1
      begin = n + 1
    Loop While Kol <> 35
      Cells(Rowbegin, "A") = Mid(Range("A2"), nStart, n - nStart)
      Rowbegin = Rowbegin + 1
      nStart = n + 1
  Loop While n < iLen
End Sub


Дмитрий!
Я потыкал мышкой по иконкам, но так как подсказки не появляются, то оставил как есть.

Код Выделить Развернуть

Sub iSort_()
Dim Itog As Worksheet
Dim iLastRow As Long
Dim i As Long
Dim sh As Shape
  Set Itog = ThisWorkbook.Worksheets("Итог")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    With Itog
      .Cells.Clear
      For Each sh In .Shapes
        If sh.Name Like "*" Then
          sh.Delete
        End If
      Next
      Range("A1:J" & iLastRow).Copy .Cells(1, 1)
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
      .Range("A22:J" & iLastRow).Sort Key1:=.Range("F4"), Order1:=xlAscending, Header:=xlYes
'        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
       
        .Range("A23") = 1
        .Range("A23").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=iLastRow - 22, Trend:=False

       
        For i = iLastRow To 23 Step -1
        If IsDate(.Cells(i - 1, "F")) Then
          If Month(.Cells(i, "F")) <> Month(.Cells(i - 1, "F")) Then
            .Rows(i).Insert
            .Range("A" & i & ":J" & i).Merge
            .Range("A" & i).HorizontalAlignment = xlCenter
            .Range("A" & i) = Format(.Cells(i + 1, "F"), "MMMM")
          End If
        End If
        Next
            .Range("A23").EntireRow.Insert
            .Range("A23 :J23").Merge
            .Range("A23 :J23").HorizontalAlignment = xlCenter
            .Range("A23 :J23") = Format(.Cells(24, "F"), "MMMM")
    End With
End Sub

Код Выделить Развернуть

Sub iSort()
Dim Itog As Worksheet
Dim iLastRow As Long
Dim i As Long
  Set Itog = ThisWorkbook.Worksheets("Èòîã")
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    With Itog
      .Cells.Clear
      Range("A1:J" & iLastRow).Copy .Cells(1, 1)
      .Range("A4:J" & iLastRow).Sort Key1:=.Range("F4"), Order1:=xlAscending, Header:=xlYes
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For i = iLastRow To 6 Step -1
        If IsDate(.Cells(i - 1, "F")) Then
          If Month(.Cells(i, "F")) <> Month(.Cells(i - 1, "F")) Then
            .Rows(i).Insert
            .Range("A" & i & ":J" & i).Merge
            .Range("A" & i).HorizontalAlignment = xlCenter
            .Range("A" & i) = Format(.Cells(i + 1, "F"), "MMMM")
          End If
        End If
        Next
            .Range("A5").EntireRow.Insert
            .Range("A5 :J5").Merge
            .Range("A5 :J5").HorizontalAlignment = xlCenter
            .Range("A5 :J5") = Format(.Cells(6, "F"), "MMMM")
    End With
End Sub

В Application.GetOpenFilename нужного параметра нет

А в

Код Выделить Развернуть

Set FD = Application.FileDialog(msoFileDialogFilePicker)есть параметр

Код Выделить Развернуть

.InitialFileName = ThisWorkbook.Path

необходимо определить начало и конец нужных страниц

Ориентируйтесь на номера строк, над которыми разрыв

Код (vb) Выделить Развернуть

iRow =ActiveSheet.HPageBreaks(i).Location.Row

Код (vb) Выделить Развернуть

ThisWorkbook.Worksheets("Лист1").Cells(Rows.Count, "B").End(xlUp).Row - 10

Если есть способ попроще

Макрос в стандартный модуль, запускать при активном листе Каталог

Код (vb) Выделить Развернуть

Sub iConcatenate()
Dim Rng As Range
Dim j As Integer
With Worksheets("Расчетник")
  .Cells.Clear
    j = 1
  For Each Rng In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(2, 2).Areas
    Range(Rng.Cells(0, 1), Rng.Cells(Rng.Count, 4)).Copy .Cells(1, j)
    j = j + 4
  Next
End With
End Sub


Оператор получает значения считывателем меток ID на 1 лист - в какую ячейку. В конец ли колонки А? Каковы дальнейшие действия оператора, опишите подробнее?
И вы не ответилиИ где у вас вывод данных с листа2 на форму?

А зачем два одинаковых сообщения? И где у вас вывод данных с листа2 на форму?

При вводе некоторых ID не сошлись суммы Итог
Макрос в модуль Листа2

Код (vb) Выделить Развернуть

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("A")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundID As Range
Dim FAdr As String
Dim LastCol As Integer
Dim j As Integer
  With Worksheets("Лист1")
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set FoundID = .Columns("A").Find(Target, , xlValues, xlWhole)
      If Not FoundID Is Nothing Then
        FAdr = FoundID.Address
        j = 1
        Do
          Target.Offset(, j) = WorksheetFunction.Sum(.Range(.Cells(FoundID.Row, 3), _
                                                  .Cells(FoundID.Row, LastCol)))
          Set FoundID = .Columns("A").FindNext(FoundID)
          j = j + 1
        Loop While FoundID.Address <> FAdr
          Target.Offset(, j) = WorksheetFunction.Sum(Range(Cells(Target.Row, 2), _
                                                  Cells(Target.Row, 4)))
      End If
  End With
End If
    Application.EnableEvents = True
End Sub


Код (vb) Выделить Развернуть

Sub Raznesti()
Dim Kol_vo As Integer
Dim KolColumn As Integer
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim j As Integer
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim Shapka As Range
  Set Shapka = Range("A1:B1")          '№ п/п, Кадастровый номер
    Kol_vo = 32                        'количество строк в разбивке
    KolColumn = 3                      'количество групп столбцов по 3
  With Worksheets("Стало")
    .Cells.Clear                       'очищаем лист "Стало"
      iLR = 1
    For i = 2 To iLastRow
      For j = 1 To KolColumn
        Shapka.Copy .Cells(iLR, (j - 1) * 3 + 1)
        Range(Cells(i, "A"), Cells(i + Kol_vo - 1, "B")).Copy .Cells(iLR + 1, (j - 1) * 3 + 1)
        i = i + Kol_vo
      Next
        iLR = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
        i = i - 1
    Next
  End With
End Sub


нужно в отдельной колонке получить URL-адрес изображения

Код (vb) Выделить Развернуть

Sub HL_Get()
Dim hl As String
Dim iRow As Long
Dim iShape As Shape
  For Each iShape In ActiveSheet.Shapes
    iRow = iShape.TopLeftCell.Row   'номер строки верхнего левого угла фигуры
    hl = iShape.Hyperlink.Address   'адресс гиперссылки
    Cells(iRow, "I") = hl
  Next
End Sub


хочу попробовать, но не знаю как

Макрос (UDF) в стандартный модуль
В любой ячейке вызов

Код (vb) Выделить Развернуть

=iChislo(A1)