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' Процедуру разместить в модуле ThisOutlookSession.
' Уровень безопасности макросов (без цифровой подписи) - низкая.
Option Explicit
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
Private Sub Application_Reminder(ByVal Item As Object)
Dim objMsg As MailItem, sAttachment As String
Set objMsg = Application.CreateItem(olMailItem)
' Путь к файлу вложения (Указанный файл "Текст.txt" находится на Рабочем столе)
sAttachment = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\Текст.txt"
If Item.MessageClass <> "IPM.Appointment" Then
Exit Sub
End If
If Item.Categories <> "Automated Email Sender" Then
Exit Sub ' Закомментировать, если у события не указана категория
End If
With objMsg
.To = Item.Location ' Место события
.Subject = Item.Subject
.Body = Item.Body
' Если файл вложения существует, то добавить в письмо
If Len(sAttachment) > 0 Then .Attachments.Add sAttachment
'.Display '' Показать письмо (для отправки вручную; вместо '.Send)
.Send
End With: Set objMsg = Nothing
End SubH3:K3.' Не самый оптимальный, но наглядный способ. Ctrl+Break - экстренная остановка.
Option Explicit
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
Sub Макрос1()
Dim i As Long
i = 3 ' Формулу будем копировать с 3-й строки
With ThisWorkbook.ActiveSheet
Do
i = i + 1
.Range("H" & i & ":K" & i) = .Range("H" & i - 1 & ":K" & i - 1).FormulaR1C1
Loop Until i = .UsedRange.Rows.Count ' Цикл ДО последней строки с данными
End With
End Sub' Таблица с данными должна начинаться с ячейки A1, лист активен. Старые данные не очищаются.
Option Explicit
Option Base 1
'123456789012345678901234567890123456h8nor@ya567890123456789012345678toster56789
Sub Создать_листы_по_последнему_столбцу()
Dim a As Integer, k As Byte, m As Variant
With ThisWorkbook
With .ActiveSheet
m = .Cells(1, 1).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count)
End With
For a = LBound(m, 1) + 1 To UBound(m, 1)
k = FindSheet(m(a, UBound(m, 2)))
If k = 0 Then
.Sheets.Add After:=.Sheets(.Sheets.Count): k = .Sheets.Count
With .Sheets(k)
.Name = m(a, UBound(m, 2))
.Cells(1, 1) = m(LBound(m, 1), 1): .Cells(1, 2) = m(LBound(m, 1), 2)
End With
End If
With .Sheets(k)
.Cells(.UsedRange.Rows.Count + 1, 1) = m(a, LBound(m, 2)) ' Нижняя граница "m"
.Cells(.UsedRange.Rows.Count + IIf(Val(Application.Version) >= 12, 0, 1), _
2) = m(a, UBound(m, 2)) ' Верхняя граница "m"
End With
Next a
End With
End Sub
Function FindSheet(ByVal SheetName As String) As Byte
Dim GetBook As Workbook, GetSheet As Worksheet
Set GetBook = ThisWorkbook
For Each GetSheet In GetBook.Worksheets
If GetSheet.Name = SheetName Then FindSheet = GetSheet.Index: Exit For
Next GetSheet: Set GetSheet = Nothing: Set GetBook = Nothing
End Functionмакросы в basic