Диапазон): =ДВССЫЛ("$A$"&СТРОКА()&":$A$"&СТРОКА())=НАЙТИ("#";КОЛОН1)+1=НАЙТИ("#";КОЛОН1;КОЛ1.СТР2)+1=НАЙТИ("#";КОЛОН1;КОЛ1.СТР3)+1=ДВССЫЛ("$B$"&СТРОКА()&":$B$"&СТРОКА())=НАЙТИ("#";КОЛОН2)+1=НАЙТИ("#";КОЛОН2;КОЛ2.СТР2)+1=НАЙТИ("#";КОЛОН2;КОЛ2.СТР3)+1Option Explicit
Option Base 1
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
Sub Merge_by_Rows() ' Без форматирования границ
Dim i As Integer, j As Integer, cnt As Integer
Dim arr() As Variant, s As String
With ActiveSheet.UsedRange ' Кол-во столбцов определяется по 1-й строке
arr = Range(Cells(1, 1), Cells(.Rows.Count + 1, Range("A1").End(xlToRight).Column))
End With
cnt = 1: s = get_Row(arr, cnt)
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
If get_Row(arr, i) <> s Then
For j = LBound(arr, 2) To UBound(arr, 2)
With ActiveSheet.Range(Cells(cnt, j), Cells(i - 1, j)).Offset(, UBound(arr, 2))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Value = arr(cnt, j)
End With
Next j
cnt = i: s = get_Row(arr, cnt)
End If
Next i
End Sub
Function get_Row(ByVal arr As Variant, ByVal num_Row As Integer) As String
Dim j As Integer
For j = LBound(arr, 2) To UBound(arr, 2)
get_Row = WorksheetFunction.Trim(get_Row & " " & arr(num_Row, j))
Next j
End FunctionSelect Case Val(Application.Version)
Case 12
' Excel 2007
Case 14
' Excel 2010, VB 7.0
Case 15
' Excel 2013
Case 16
' Excel 2016, VB 7.1
Case 17
' Excel 2019
Case Else
' Прочие
End SelectCells(row, column).Interior.ColorIndex ' принимает значения от 0 до 56 Private Declare Function WideCharToMultiByte Lib "kernel32.dll" _
(ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr _
As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, _
ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Public Function ToUTF8(ByVal sText As String) As String
Dim nRet As Long, strRet As String
strRet = String(Len(sText) * 2, vbNullChar)
nRet = WideCharToMultiByte(65001, &H0, StrPtr(sText), Len(sText), _
StrPtr(strRet), Len(sText) * 2, 0&, 0&)
ToUTF8 = Left(StrConv(strRet, vbUnicode), nRet)
End Function
Sub test() ' Пример работы с функцией '
text = ToUTF8(textANSI)
End Sub =СУММ(B$1:B1)Application лучше написать WorksheetFunction.' НомерСтроки - Кол-во непустых ячеек в колонке "1" + 1, а не номер первой пустой строки' НомерСтроки - Номер первой пустой строки на рабочем листе
НомерСтроки = ActiveSheet.Cells.SpecialCells(xlLastCell).Row + 1КолНепустых = ActiveCell.SpecialCells(xlCellTypeLastCell).Row - _
ActiveCell.EntireColumn.SpecialCells(xlCellTypeBlanks).Count 
Файл -> Параметры -> Дополнительно (вкладка) -> Общие (раздел)
(√) Игнорировать DDE-запросы от других приложений
Option Explicit ' Обязательное объявление переменных
Option Base 1 ' Нижняя граница массива (по умолчанию)
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
Sub Border_Limit()
Dim Limit As Integer, Count As Integer, SaveDir As String, SetTitle As Boolean
Count = 1: Limit = 1000 ' Счётчик файлов; Количество строк
SetTitle = False ' Если есть заголовок, заменить False на True
SaveDir = ThisWorkbook.Path ' Или вписать полный путь для сохранения "C:\"
' Предполагается, что в колонке A нет пустых ячеек
While Not IsEmpty(Cells(IIf(SetTitle, 2, 1), 1))
Rows("1:" & Limit).Copy
Workbooks.Add xlWBATWorksheet ' Создать новую книгу: шаблон с 1 листом
ActiveSheet.Paste: Cells(1, 1).Select
ActiveWorkbook.SaveAs Filename:=SaveDir & "\Массив_" & Count & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
ActiveWindow.Close
Rows(IIf(SetTitle, 2, 1) & ":" & Limit).Delete Shift:=xlUp
Count = Count + 1
Wend: MsgBox "Файл разбит на " & Count - 1 & " файл(ов). "
End Sub