Никита Дворец

Добрый день.
Вариант с помощью макроса. Если нужен "автомат", придется применять макрос по событию.

=ТЕКСТ(I1109;"ДД.ММ.ГГГГ")

Добрый день.
Можно воспользоваться макросом переноса данных по событию на заданное время, до момента очистки данных.

Добрый день.
На примере Excel.

Добрый день!
Примерно по такой логике:
' открыты обе книги

' Set rgCopy = wb1.Sheets(1).Range(Cells(8, 1), Cells(65, 13))
' rgCopy.Copy Destination:=wb2.Sheets(1).Range("A8:M65")

Application.CutCopyMode = False

Dim wb1 As Workbook
Set wb1 = ActiveWorkbook


Dim wb2 As Workbook
Set wb2 = Workbooks("C:\Users\DataFile.xlsm")

wb1.Activate
wb1.Sheets(1).Range(Cells(8, 1), Cells(65, 13)).Copy

wb2.Activate
wb2.Sheets(1).Range("A8").Select
Selection.Paste

Application.CutCopyMode = True

Пояснение по методу Evaluate

Добрый день.
Вариант: пользовательская функция


Модель:
https://disk.yandex.ru/d/iNcbmzC1ZOVG1g

Добрый день.
На листе Excel. Вариант макросом VBA Excel.

Добрый день.
Вариант пользовательской функции VBA Excel.

Вариант: Макрос VBA Excel
Sub massiv()

With Worksheets("Transpose")

Dim arr1() As Variant
Dim arr2() As Variant
Dim arr3() As Variant

Dim i, j, n As Integer


n = 0
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row Step 3
ReDim Preserve arr1(n)
arr1(n) = .Cells(i, 2).Value
n = n + 1
Next i

n = 0
For j = 2 To 5 Step 1
.Range("C" & j).Value = arr1(n)
n = n + 1
Next j

' ============================================
n = 0
For i = 3 To Cells(Rows.Count, 2).End(xlUp).Row Step 3
ReDim Preserve arr2(n)
arr2(n) = .Cells(i, 2).Value
n = n + 1
Next i

n = 0
For j = 2 To 5 Step 1
.Range("D" & j).Value = arr2(n)
n = n + 1
Next j

' ============================================
n = 0
For i = 4 To Cells(Rows.Count, 2).End(xlUp).Row Step 3
ReDim Preserve arr3(n)
arr3(n) = .Cells(i, 2).Value
n = n + 1
Next i

n = 0
For j = 2 To 5 Step 1
.Range("E" & j).Value = arr3(n)
n = n + 1
Next j

End With
End Sub

Вариант: с помощью пользовательской функции
Option Explicit

Public Function SearchClickbait(TestString As String, ClickbaitRange As Range) As String
' ClickbaitRange - диапазон на листе с ключевыми словами
' TestString - ячейка с анализируемым текстом
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rCell As Range

Dim Pos As Long

With ws
SearchClickbait = "не информативный запрос"
For Each rCell In ClickbaitRange.Cells

Pos = InStr(1, TestString, rCell.Text, 1)
If Pos >= 1 Then
SearchClickbait = "(!)информативный запрос"
Exit Function
Else
End If
Next rCell

End With

End Function

Вариант:

Public Sub FindPicture()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
MsgBox ("Img")
Else
End If
Next shp
End Sub

Добрый день.
Вариант UDF вместо формулы.
Public Function ExtractRandom(ByRef TargetRange As Excel.Range)
Dim rCell As Range
Randomize
ExtractRandom = TargetRange.Cells(Int(Rnd * TargetRange.Count) + 1)

If ExtractRandom = 0 Then
For Each rCell In TargetRange.Cells
If rCell.Value <> 0 Then
ExtractRandom = rCell.Value
Exit Function
Else
End If
Next rCell
Else
End If
End Function

Вариант VBA Excel для задачи "найти и разъединить":

Sub FindMergedCells()
Dim TheRange As Range
For Each TheRange In ActiveSheet.UsedRange
If TheRange.MergeCells Then
ActiveSheet.Cells.UnMerge
Else
End If
Next TheRange
End Sub

Добрый день.
На мой взгляд, нагляднее разработать макрос в VBA Excel, который сформирует график по исходным данным на отдельном листе.