🖥 Вывод разрешения экрана

🛠 Вывод текущего разрешения экрана компьютера с помощью VBA Excel:

' Объявление API-функции для 64-разрядных платформ
Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As LongPtr) As LongPtr
    
' Объявление API-функции для 32-разрядных платформ
' Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Sub GetMonitorXY()
    MsgBox "Текущее разрешение экрана: " & GetSystemMetrics(0) & " x " & GetSystemMetrics(1)
End Sub

#VBA #ExcelVBA #GetSystemMetrics #РазрешениеЭкрана

✂️ Обрезание расширения файла

Подходит для файлов, в наименовании которых есть только одна точка, которая стоит перед расширением:

Sub RemoveFileExtension()
    If InStr(ThisWorkbook.Name, ".") > 1 Then
        MsgBox "Имя файла с расширением: " & ThisWorkbook.Name & vbNewLine & _
        "Имя файла без расширения: " & Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1)
    End If
End Sub

#VBA #ExcelVBA #Расширение #Extension

📖 Вывод списка листов
Выводим список всех листов текущей книги, включая листы диаграмм, в MsgBox и в первый столбец активного листа.

1️⃣ Вывод списка листов в MsgBox:

Sub SheetsToMsgBox()
Dim mySheet As Object, s As String
    For Each mySheet In Sheets
        s = s & mySheet.Name & vbNewLine
    Next
MsgBox s
End Sub

2️⃣ Вывод списка листов в первый столбец активного листа:

Sub SheetsToRange()
Dim mySheet As Object, i As Integer
    For Each mySheet In Sheets
        i = i + 1
        Cells(i, 1) = mySheet.Name
    Next
End Sub

#VBA #ExcelVBA #СписокЛистов

🏃‍♀️ Бегущая строка
Следующий код VBA Excel создаст бегущую строку в указанной ячейке (в примере - Cells(1, 1)).

🛠 Можно задавать:
🔹 Свой текст бегущей строки
🔹 Расстояние между двумя бегущими строками
🔹 Количество пробежавших строк до остановки процедуры
🔹 Скорость бегущей строки
🔹 Ячейку, в которой побежит строка

Код бегущей строки:

Sub BegushchayaStroka()
Dim stroka1 As String, stroka2 As String, yacheyka As Range, _
probely As Integer, dlina As Integer, kolichestvo As Integer, _
zaderzhka As Single, start As Single, i1 As Integer, i2 As Integer
 
stroka1 = "Моя бегущая строка" 'Текст бегущей строки
probely = 25 'Расстояние между бегущими строками
kolichestvo = 3 'Количество пробежавших строк
zaderzhka = 0.05 'Регулирует скорость бегущей строки
Set yacheyka = Cells(1, 1) ' Ячейка с бегущей строкой
 
stroka1 = Space(probely) & stroka1
dlina = Len(stroka1)
    With yacheyka
        .Value = stroka1
        .EntireColumn.AutoFit
    End With
    For i1 = 1 To kolichestvo
        For i2 = 1 To dlina
        stroka2 = Right(stroka1, dlina - i2) & Left(stroka1, i2)
        yacheyka.Value = stroka2
            start = Timer
            Do While Timer < start + zaderzhka
               DoEvents
            Loop
        Next
    Next
End Sub

#VBA #ExcelVBA #БегущаяСтрока

📅 Вывод текущей даты и времени

1️⃣ Вывод текущей даты в формате "Short Date":

Sub OutputShortDateTime()
MsgBox "Привет!" & vbNewLine & "Сегодня " & WeekdayName(Format(Now, "w", vbMonday)) _
& " " & Format(Now, "Short Date") & " года" & vbNewLine & "Время: " & Format(Now, "Short Time")
End Sub

2️⃣ Вывод текущей даты в полном формате и приветствия в соответствии со временем суток:

Sub OutputLongDateTime()
Dim pr As String, ms As String
    If TimeValue(Time) > TimeValue("9:00") And TimeValue(Time) <= TimeValue("15:00") Then
        pr = "Добрый день!"
    ElseIf TimeValue(Time) > TimeValue("15:00") And TimeValue(Time) <= TimeValue("21:00") Then
        pr = "Добрый вечер!"
    ElseIf TimeValue(Time) > TimeValue("21:00") And TimeValue(Time) <= TimeValue("3:00") Then
        pr = "Доброй ночи!"
    Else
        pr = "Доброе утро!"
    End If
ms = Choose(Month(Now), "января", "февраля", "марта", "апреля", "мая", "июня", "июля", _
"августа", "сентября", "октября", "ноября", "декабря")
MsgBox pr & vbNewLine & "Сегодня " & WeekdayName(Format(Now, "w", vbMonday)) _
& " " & Day(Now) & " " & ms & " " & Year(Now) & " года" & vbNewLine & "Время: " & Format(Now, "Short Time")
End Sub

#VBA #ExcelVBA #Date #Time #Дата #Время

📂 Просмотр содержимого папки в VBA Excel
Если вам нужно получить список подпапок или файлов из определенной папки в Excel, VBA легко справится с этой задачей!

1️⃣ Просмотр подпапок в выбранной папке:

Sub ПросмотрПапок()
    Dim ws As Worksheet
    Dim FSO As Object
    Dim FolderPath As String
    Dim SubFolder As Object
    Dim FolderDialog As Object
    Dim Row As Integer
    
    ' Выбор папки через диалоговое окно
    Set FolderDialog = Application.FileDialog(4) ' 4 – выбор папки
    If FolderDialog.Show = -1 Then
        FolderPath = FolderDialog.SelectedItems(1)
    Else
        Exit Sub
    End If

    ' Работа с подпапками
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ws = ThisWorkbook.Sheets(1)
    
    ws.Cells.Clear ' Очистка листа перед вставкой данных
    ws.Cells(1, 1).Value = "Папки в: " & FolderPath
    ws.Cells(2, 1).Value = "Имя папки"
    
    Row = 3
    For Each SubFolder In FSO.GetFolder(FolderPath).SubFolders
        ws.Cells(Row, 1).Value = SubFolder.Name
        Row = Row + 1
    Next SubFolder
    
    MsgBox "Просмотр завершен! Найдено " & Row - 3 & " папок.", vbInformation, "Готово"
    
End Sub

🔹 Как это работает?
✅ Открывается диалоговое окно для выбора папки 📁
✅ Код перебирает файлы в выбранной папке и записывает их имена на лист Excel 📜
✅ Показывается сообщение о завершении работы 🚀

2️⃣ Просмотр файлов в выбранной папке:

Sub ПросмотрФайлов()
    Dim ws As Worksheet
    Dim FSO As Object
    Dim FolderPath As String
    Dim FileItem As Object
    Dim FolderDialog As Object
    Dim Row As Integer
    
    ' Выбор папки через диалоговое окно
    Set FolderDialog = Application.FileDialog(4) ' 4 – выбор папки
    If FolderDialog.Show = -1 Then
        FolderPath = FolderDialog.SelectedItems(1)
    Else
        Exit Sub
    End If

    ' Работа с файлами в папке
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ws = ThisWorkbook.Sheets(1)
    
    ws.Cells.Clear ' Очистка листа перед вставкой данных
    ws.Cells(1, 1).Value = "Файлы в папке: " & FolderPath
    ws.Cells(2, 1).Value = "Имя файла"
    
    Row = 3
    For Each FileItem In FSO.GetFolder(FolderPath).Files
        ws.Cells(Row, 1).Value = FileItem.Name
        Row = Row + 1
    Next FileItem
    
    MsgBox "Просмотр завершен! Найдено " & Row - 3 & " файлов.", vbInformation, "Готово"
    
End Sub

🔹 Как работает этот код?
✅ Открывает диалоговое окно для выбора папки 📂
✅ Перебирает папки внутри выбранной директории и выводит их список на лист Excel 📜
✅ Показывает уведомление о завершении 🚀

#VBA #ExcelVBA #GetFolder #SubFolders #Files

〰️💲Тильда и знак доллара перед именем файла
Иногда, при просмотре списка файлов, можно обнаружить тильду со знаком доллара (~$) перед именем файла.

Файл с именем ~$Книга1.xlsm (с тильдой и знаком доллара в начале) – это временный (скрытый) файл, который Excel автоматически создает при открытии основного файла Книга1.xlsm.

🔍 Что означает этот значок?
🔹 ~$ – это префикс, который Excel использует для обозначения временных файлов.
🔹 Книга1.xlsm – оригинальное имя файла, к которому относится этот временный файл.

📌 Для чего нужен этот файл?
🔹 Блокировка файла – предотвращает одновременное редактирование не одним пользователем.
🔹 Временное хранение данных – помогает восстановить файл в случае сбоя.
🔹 Хранение информации о пользователе – если другой пользователь попробует открыть файл в сети, Excel покажет сообщение, что файл уже открыт кем-то другим.

🔄 Когда он исчезает?
Обычно этот файл удаляется автоматически после закрытия Excel. Но если Excel завершился некорректно (например, произошел сбой), временный файл может остаться в папке.

🛠 Что делать, если он не исчезает?
🔹 Закройте все экземпляры Excel.
🔹 Проверьте, не открыт ли основной файл.
🔹 Перезагрузите компьютер.
🔹 Если файл остался и мешает, его можно удалить вручную.

💡 Вывод
Файлы с префиксом ~$ не нужно трогать во время работы Excel – это его рабочие файлы. Если они остаются после закрытия, можно их удалить вручную. 🚀

#Prefix #Префикс #Тильда #ЗнакДоллара

📅 Заполнение ComboBox названиями месяцев
Три способа заполнения поля со списком (ComboBox) названиями месяцев.

📌 Примеры

1️⃣ Загружаем в ComboBox список месяцев на русском языке, по умолчанию отображаем Январь:

Private Sub UserForm_Initialize()
    With ComboBox1
        .List = Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", _
            "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
        .Value = "Январь"
    End With
End Sub

Если же необходимо загрузить в ComboBox названия месяцев на языке пользователя, используем 2 и 3 примеры.

2️⃣ Загружаем в ComboBox список месяцев на языке пользователя, по умолчанию отображаем первый месяц:

Private Sub UserForm_Initialize()
    With ComboBox1
        .List = Array(MonthName(1), MonthName(2), MonthName(3), MonthName(4), _
            MonthName(5), MonthName(6), MonthName(7), MonthName(8), _
            MonthName(9), MonthName(10), MonthName(11), MonthName(12))
        .Value = MonthName(1)
    End With
End Sub

3️⃣ То же самое, что и во втором примере, но с помощью цикла:

Private Sub UserForm_Initialize()
Dim i As Byte
    With ComboBox1
        For i = 1 To 12
            .AddItem MonthName(i)
        Next
            .Value = MonthName(1)
    End With
End Sub

#VBA #ExcelVBA #ComboBox #AddItem #List #MonthName

🔲 Создание квадратной ячейки
Квадратную ячейку в Excel можно сделать вручную , выбрав ширину и высоту с одинаковым количеством пикселей. Но как это сделать программно?

В VBA Excel нет прямого способа задать ширину столбцов и высоту строк в пикселях, так как Excel использует свои собственные единицы измерения: для ширины столбцов — это количество символов стандартного шрифта, а для высоты строк — пункты (points). Однако можно приблизительно перевести пиксели в эти единицы.

🔹 Высота строки в Excel измеряется в пунктах (points). Один пункт равен примерно 1.33 пикселя.
🔹 Ширина столбца в Excel измеряется в количестве символов стандартного шрифта. Один символ стандартного шрифта равен примерно 7 пикселям.

📌 Пример

Sub SquareCell()
    With Range("A1")
        .EntireRow.RowHeight = 100 / 1.33
        .EntireColumn.ColumnWidth = 100 / 7
    End With
End Sub

⚠️ Важные замечания
🔹 Эти формулы дают приблизительные значения, так как реальное соотношение между пикселями и единицами Excel может зависеть от настроек шрифта и масштабирования.
🔹 Этот способ позволяет задать ширину столбцов и высоту строк в пикселях с достаточной точностью для наглядного восприятия.

#VBA #ExcelVBA #RowHeight #ColumnWidth #пункт #символ

📋 Создание выпадающего списка в ячейке Excel
Выпадающие списки в ячейках Excel помогают ограничить ввод данных и ускорить работу с таблицами. Их можно создать вручную через "Проверку данных", но VBA позволяет сделать это автоматически.

📌 Примеры

1️⃣ Простой выпадающий список для ячейки A1

Sub AddDropDownList()
    With Range("A1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="Кофе,Чай,Сок,Молоко,Какао"
    End With
End Sub

✅ Что делает этот код?
🔹 Удаляет старые правила (.Delete).
🔹 Создает выпадающий список в ячейке A1 с вариантами: Кофе, Чай, Сок, Молоко, Какао.

2️⃣ Создание выпадающего списка на основе диапазона

Sub DropDownFromRange()  
    With Range("A1").Validation  
        .Delete  
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="=B1:B5"  
    End With  
End Sub

✅ Теперь при изменении значений в B1:B5 список обновится автоматически!

3️⃣ Создание динамического выпадающего списка

Sub DynamicDropDown()
    ActiveWorkbook.Names.Add Name:="Список", RefersTo:="=B1:INDEX(B:B,COUNTA(B:B))"
    With Range("A1").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, Formula1:="=Список"
    End With
End Sub

✅ Динамический список автоматически расширится при добавлении новых значений в колонку B.

4️⃣ Удаление выпадающего списка

Sub RemoveDropDown()
    Range("A1").Validation.Delete
End Sub

#VBA #ExcelVBA #Validation #ВыпадающийСписок

✨ Удаление пустых строк 2
Простое, но действенное, удаление пустых строк на всем листе по пустым ячейкам заданного столбца. Будут удалены и те строки, в которых есть значения в других столбцах.

📌 Пример

Sub DeleteEmptyRows()
    On Error Resume Next
        Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
End Sub

#VBA #ExcelVBA #ПустыеСтроки #EmptyRows #УдалениеПустыхСтрок

✨ Простое удаление дубликатов

📌 Примеры

1️⃣ Удаление дубликатов из списка в одном столбце

Sub RemoveDuplicates1()
    ActiveSheet.Range("A1:A20").RemoveDuplicates Columns:=Array(1)
End Sub

2️⃣ Удаление строк с дубликатами из таблицы

Sub RemoveDuplicates2()
    ActiveSheet.Range("A1:D20").RemoveDuplicates Columns:=Array(3), Header:=xlYes
End Sub

🔹 Из таблицы будут удалены строки, в которых есть повторы значений в заданном столбце (Columns:=Array(3)).
🔹 В параметре Columns может быть задано несколько столбцов, через запятую, для проверки наличия дубликатов в нескольких столбцах. Например: (Columns:=Array(1, 2)).
🔹 Header:=xlYes указывает на то, что в таблице есть заголовки, которые не должны учитываться при поиске дубликатов.

#VBA #ExcelVBA #RemoveDuplicates #УдалениеДубликатов

✨ Отбор уникальных значений из списка
Нетрадиционный способ отбора уникальных значений из списка в VBA Excel. Используем объект Dictionary.

📌 Примеры

1️⃣ Отбор уникальных значений из столбца A и выгрузка их на рабочий лист в столбец B:

Sub Primer1()
Dim myDictionary As Object, myCell As Range, myElement As Variant
    Set myDictionary = CreateObject("Scripting.Dictionary")
        'Отбор уникальных значений из списка в столбце A
        For Each myCell In Range("A1:A20")
          myElement = myDictionary.Item(CStr(myCell))
        Next
    'Выгрузка уникальных значений на рабочий лист в столбец B
    Range("B1").Resize(myDictionary.Count) = Application.Transpose(myDictionary.Keys)
End Sub

Как работает этот код?
🔹 При присвоении переменной myElement значения myDictionary.Item(CStr(myCell)) с несуществующем ключом, значение myCell записывается как ключ, а как значение записывается Empty, которое и присваивается переменной myElement.
🔹 Если значение myCell повторяется, оно игнорируется, так как все ключи в myDictionary должны быть уникальными.
🔹 Списком уникальных значений является полученный список ключей словаря (myDictionary.Keys), которые мы выгружаем на рабочий лист в колонку B.
🔹 Транспонирование (Application.Transpose) необходимо для того, чтобы горизонтальный список ключей словаря вставить в вертикальный список в столбце B.

2️⃣ Отбор уникальных значений из столбца A и выгрузка их в поле со списком (ComboBox):

Sub Primer2()
Dim myDictionary As Object, myCell As Range, myElement As Variant
    Set myDictionary = CreateObject("Scripting.Dictionary")
        'Отбор уникальных значений из списка в столбце A
        For Each myCell In Range("A1:A20")
          myElement = myDictionary.Item(CStr(myCell))
        Next
    'Выгрузка уникальных значений в поле со списком
    With UserForm1
        .ComboBox1.List = myDictionary.Keys
        .Show
    End With
End Sub

#VBA #ExcelVBA #Dictionary #ОтборУникальных #УникальныеЗначения #ComboBox

📖 Создание оглавления
Автоматическое создание оглавления (содержания) для всех листов в рабочей книге Excel с помощью VBA.

👍 Если у вас в файле много листов, можно создать оглавление, где каждая строка — это ссылка на определенный лист. Такой список поможет быстро переключаться между страницами. Кроме того, в соседнем столбце можно разместить какие-либо комментарии к соответствующему листу.

📌 Код VBA Excel:

Sub CreateTableOfContents()
    Dim ws As Object, toc As Object
    Dim i As Integer
    
    ' Удаляем старый лист "Оглавление", если он уже существует
    On Error Resume Next
        Application.DisplayAlerts = False
            Sheets("Оглавление").Delete
        Application.DisplayAlerts = True
    On Error GoTo 0

    ' Создаем новый лист "Оглавление"
    Set toc = Sheets.Add(Before:=Sheets(1))
    toc.Name = "Оглавление"
    
    ' Заголовок
    toc.Cells(1, 1).Value = "Оглавление"
    toc.Cells(1, 1).Font.Bold = True
    toc.Cells(1, 1).Font.Size = 14

    ' Добавляем ссылки на листы
    i = 2
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Оглавление" Then
            toc.Cells(i, 1).Value = ws.Name
            toc.Hyperlinks.Add Anchor:=toc.Cells(i, 1), _
                Address:="", SubAddress:="'" & ws.Name & "'!A1", _
                TextToDisplay:=ws.Name
            i = i + 1
        End If
    Next ws

    ' Автоширина столбца
    toc.Columns("A").AutoFit

    MsgBox "Оглавление создано!", vbInformation, "Готово!"
End Sub

📌 Как работает макрос?
🔹 Создает новый лист "Оглавление".
🔹 Записывает список всех листов.
🔹 Добавляет гиперссылки для перехода.

#VBA #ExcelVBA #Оглавление #Содержание #Hyperlinks #SubAddress

📄 Добавление нового листа в оглавление
После добавления в книгу нового листа, с помощью предыдущего кода можно обновить оглавление. Но, если вы включили в оглавление какие-то дополнительные пометки и комментарии, они будут удалены вместе со старым листом "Оглавление". Чтобы сохранить пометки и комментарии, можно просто добавить ссылку на новый лист в существующее оглавление.

📌 Код VBA Excel:

Sub AddItemToTableOfContents()
    Dim ws As String, n As LongLong
    ws = ActiveSheet.Name
        If MsgBox("Добавить лист «" & ws & "» в Оглавление?", 33) = 1 Then
            Sheets("Оглавление").Activate
            ' Определяем номер строки первой незаполненной ячейки
            n = Cells(Rows.Count, 1).End(xlUp).Row + 1
            ' Добавляем ссылку на активный лист
            Cells(n, 1).Value = ws
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(n, 1), _
                Address:="", SubAddress:="'" & ws & "'!A1", _
                TextToDisplay:=ws
        ' Автоширина столбца
        Columns("A").AutoFit
        MsgBox "Лист «" & ws & "» добавлен в Оглавление!", vbInformation, "Готово!"
        End If
End Sub

📌 Как работает макрос?
🔹 Спрашивает пользователя о необходимости добавления в оглавление ссылки на активный лист.
🔹 Если пользователь отвечает «OK», макрос записывает ссылку на активный лист в первую свободную ячейку первого столбца листа "Оглавление".

#VBA #ExcelVBA #Оглавление #Содержание #Hyperlinks #SubAddress

Примеры программ на VBA Excel
Бегущая строка
Валидация ввода данных в поля формы VBA Excel
Вставка интервала дат (DateAdd)
Вставка интервала дат (DateSerial)
Вставка текущей даты в ячейки Excel
Выбор позиции в списке
Вывод разрешения экрана
Вывод списка листов
Выравнивание заголовка кодом VBA
Генератор паролей на VBA Excel
Добавление нового листа в оглавление
Запись значений диапазона в обычную переменную
Заполнение ComboBox названиями месяцев
Защита кода VBA паролем
Как запретить закрытие файла Excel?
Максимизация окна Excel при открытии
Необязательные параметры в VBA Excel
Номер последней заполненной строки
Обрезание расширения файла
Отбор уникальных значений из списка
Открыть сайт или файл для просмотра
Отправка писем по e-mail
Парсинг содержимого тегов с сайта в VBA Excel
Перемещение столбцов и строк с помощью VBA
Поздравление-сюрприз от VBA Excel
Проверка версий офисных программ
Программное создание модуля и процедуры
Программное создание элементов управления
Просмотр содержимого папки в VBA Excel
Простое удаление дубликатов
Работа с буфером обмена в VBA Excel
Расположение формы в окне Excel
Редактирование текста в ячейке из кода VBA
Смена заголовка окна Excel
Смена кодировки UTF-8 на UTF-16
Снятие пароля с проекта VBA Excel
Создание календаря в VBA Excel
Создание квадратной ячейки
Создание оглавления
Создание пользовательского меню
Создание резервной копии файла
Список изменений на листе Excel
Список подключенных библиотек
Сумма прописью для документов
Текст в строке состояния
Удаление всех гиперссылок
Удаление всех пустых строк и столбцов
Удаление пустых строк 1
Удаление пустых строк 2
Удаляющаяся и приближающаяся строка
Форма на весь экран в VBA Excel
Чтение текста из файла с помощью FileSystemObject
Экспорт данных из Excel в PDF

#VBA #ExcelVBA #Sub #Function #Программа #Пример

🗑 Удаление всех пустых строк и столбцов в Excel
Если в вашей таблице накопились пустые строки и столбцы, их можно быстро удалить с помощью макроса VBA. Это поможет избавиться от лишнего пространства и оптимизировать данные.

📌 Код VBA

Sub DeleteEmptyRowsAndColumns()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long

    Set ws = ActiveSheet

    Application.ScreenUpdating = False  ' Отключаем обновление экрана для ускорения

    ' Удаление пустых строк (снизу вверх, чтобы не нарушить нумерацию)
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    For i = lastRow To 1 Step -1
        If WorksheetFunction.CountA(ws.Rows(i)) = 0 Then
            ws.Rows(i).Delete
        End If
    Next i

    ' Удаление пустых столбцов (справа налево)
    lastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    For i = lastCol To 1 Step -1
        If WorksheetFunction.CountA(ws.Columns(i)) = 0 Then
            ws.Columns(i).Delete
        End If
    Next i

    Application.ScreenUpdating = True  ' Включаем обновление экрана

    MsgBox "Все пустые строки и столбцы удалены!", vbInformation, "Готово!"
End Sub

📌 Как работает макрос?
🔹 Проверяет каждую строку и удаляет, если она пустая.
🔹 Затем делает то же самое со столбцами.
🔹 Работает на активном листе.

⚠️ Важно
🔹 Диапазон обработки определяется переменными lastRow и lastCol по первой строке и первому столбцу. На рабочем листе могут оказаться заполненные ячейки вне диапазона по другим строкам и столбцам. Если у вас остались на листе ненужные пустые строки и столбцы, замените 1 в выражениях ws.Cells(Rows.Count, 1) и /или ws.Cells(1, Columns.Count) на нужную цифру.

⚡️ Теперь ваша таблица чистая и аккуратная без пустых строк и столбцов!

#VBA #ExcelVBA #УдалениеСтрок #УдалениеСтолбцов

📩 Создание и отправка отчетов по электронной почте в Excel
Если вам нужно регулярно отправлять отчеты по e-mail, можно автоматизировать этот процесс с помощью VBA и Outlook. Макрос позволит создать письмо, прикрепить файл и отправить его всего одним кликом! 🚀

📌 Код VBA

Sub SendReportByEmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ReportFile As String

    ' Указываем путь для сохранения временного PDF-отчета
    ReportFile = ThisWorkbook.Path & "\Отчет.pdf"
    
    ' Сохраняем текущий лист в PDF
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ReportFile, _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, OpenAfterPublish:=False

    ' Создаем объект Outlook
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "example@email.com"  ' Укажите получателя
        .CC = ""  ' Копия (если нужно)
        .BCC = "" ' Скрытая копия (если нужно)
        .Subject = "Автоматический отчет: " & Format(Date, "dd.mm.yyyy")
        .Body = "Добрый день!" & vbNewLine & vbNewLine & _
                "Во вложении автоматически сгенерированный отчет." & vbNewLine & _
                "Если возникнут вопросы, пожалуйста, свяжитесь со мной." & vbNewLine & vbNewLine & _
                "С уважением," & vbNewLine & "Ваше имя"
        .Attachments.Add ReportFile  ' Прикрепляем PDF-файл
        .Send  ' Отправляем письмо
    End With

    ' Удаляем временный файл
    Kill ReportFile

    ' Очищаем объекты
    Set OutMail = Nothing
    Set OutApp = Nothing

    MsgBox "Отчет успешно отправлен!", vbInformation, "Готово!"
End Sub

📌 Как работает макрос?
🔹 Создает новое письмо в Outlook.
🔹 Добавляет получателя, тему и текст письма.
🔹 Прикрепляет PDF-отчет, сконвертированный из активного листа Excel.
🔹 Автоматически отправляет письмо.
🔹 Outlook может попросить подтвердить отправку (у меня спрашивает).

#VBA #ExcelVBA #Outlook #Отправить #Письмо #Отчет

📆 Автоматическое создание календаря в VBA Excel
Если вам нужно создать месячный календарь на листе Excel, можно использовать VBA для генерации таблицы с заголовком, днями недели и датами. 🚀

📌 Код VBA Excel для создания календаря:

Sub CreateCalendar()
    Dim ws As Worksheet
    Dim startDate As Date, endDate As Date
    Dim firstDay As Integer, lastDay As Integer
    Dim yearInput As Integer, monthInput As Integer
    Dim i As Integer, rowOffset As Integer

    ' Запрос у пользователя месяца и года
    yearInput = InputBox("Введите год:", "Год", Year(Date))
    monthInput = InputBox("Введите номер месяца (1-12):", "Месяц", Month(Date))

    ' Проверка корректности ввода
    If monthInput < 1 Or monthInput > 12 Then
        MsgBox "Ошибка! Введите месяц от 1 до 12.", vbCritical, "Ошибка ввода"
        Exit Sub
    End If

    ' Определяем первый и последний день месяца
    startDate = DateSerial(yearInput, monthInput, 1)
    lastDay = Day(DateSerial(yearInput, monthInput + 1, 0))

    ' Создаем новый лист
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = Format(startDate, "mmmm yyyy")

    ' Заголовок
    ws.Cells(1, 1).Value = Format(startDate, "mmmm yyyy")
    ws.Cells(1, 1).Font.Bold = True
    ws.Cells(1, 1).Font.Size = 14
    Range("A1:G1").HorizontalAlignment = xlCenterAcrossSelection

    ' Заголовки дней недели
    Dim daysArray As Variant
    daysArray = Array("Пн", "Вт", "Ср", "Чт", "Пт", "Сб", "Вс")
    For i = 0 To 6
        ws.Cells(3, i + 1).Value = daysArray(i)
        ws.Cells(3, i + 1).Font.Bold = True
        ws.Cells(3, i + 1).HorizontalAlignment = xlCenter
    Next i

    ' Заполнение календаря
    firstDay = Weekday(startDate, vbMonday) ' Определяем день недели 1-го числа
    rowOffset = 4
    i = 1

    Do While i <= lastDay
        ws.Cells(rowOffset, firstDay).Value = i
        ws.Cells(rowOffset, firstDay).HorizontalAlignment = xlCenter
        ws.Cells(rowOffset, firstDay).VerticalAlignment = xlCenter
        ws.Cells(rowOffset, firstDay).Borders.LineStyle = xlContinuous

        ' Перемещение к следующему дню
        If firstDay = 7 Then
            rowOffset = rowOffset + 1
            firstDay = 1
        Else
            firstDay = firstDay + 1
        End If
        i = i + 1
    Loop

    ' Автоширина столбцов
    ws.Columns.AutoFit

    MsgBox "Календарь успешно создан!", vbInformation, "Готово!"
End Sub

📌 Как работает макрос?
🔹 Запрашивает у пользователя месяц и год.
🔹 Создает таблицу календаря.
🔹 Заполняет даты и форматирует ячейки.

#VBA #ExcelVBA #Календарь #Calendar

🔠 Разделение текста по столбцам
Разделение текста из ячейки по столбцам в VBA Excel с настройкой разделителей.

Если у вас есть данные в одной колонке, разделенные запятыми, пробелами или другими символами, их можно автоматически разделить на отдельные столбцы с помощью VBA. Это особенно полезно для работы с CSV-файлами, списками или импортированными данными. 🚀

📌 Код VBA для преобразования текста в столбцы:

Sub SplitTextToColumns()
    Dim ws As Worksheet
    Dim rng As Range
    Dim delimiter As String

    ' Выбор активного листа
    Set ws = ActiveSheet
    
    ' Запрос у пользователя разделителя
    delimiter = InputBox("Введите разделитель (например, запятая, точка с запятой, пробел или другой):", "Выбор разделителя", ",")

    ' Проверка, был ли введен разделитель
    If delimiter = "" Then
        MsgBox "Ошибка! Вы не ввели разделитель.", vbExclamation, "Ошибка"
        Exit Sub
    End If

    ' Выбор диапазона (можно сразу указать нужный диапазон)
    On Error Resume Next
        Set rng = Application.InputBox("Выберите диапазон с текстом:", "Выбор диапазона", Type:=8)
    On Error GoTo 0
    
    If rng Is Nothing Then Exit Sub  ' Если пользователь отменил выбор

    ' Разбиваем текст по столбцам
    rng.TextToColumns Destination:=rng.Cells(1, 1), _
                      DataType:=xlDelimited, _
                      TextQualifier:=xlDoubleQuote, _
                      ConsecutiveDelimiter:=False, _
                      Tab:=False, _
                      Semicolon:=False, _
                      Comma:=False, _
                      Space:=False, _
                      Other:=True, _
                      OtherChar:=delimiter

    MsgBox "Данные успешно разделены по столбцам!", vbInformation, "Готово!"
End Sub

Этот блок в данный момент никакой функции не исполняет

ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _

но с его помощью можно указать разделитель сразу в коде, присвоив нужному элементу значение True.

📌 Как работает макрос?
🔹 Запрашивает у пользователя сначала указать разделитель, потом диапазон ячеек с текстом.
🔹 Разбивает текст в выбранном диапазоне на отдельные столбцы.
🔹 Позволяет использовать любой разделитель (запятая, точка с запятой, пробел и т. д.).

🔥 Теперь данные разделятся на отдельные столбцы, и вам не придется делать это вручную!

#VBA #ExcelVBA #Delimiter #Разделитель #Текст #ПоСтолбцам