Макрос, чтобы проверял, заполнены ли поля или нет?

@Olesya-lisa89 · Регистрация: 07.11.2018

Студворк — интернет-сервис помощи студентам

Добрый день. Помогите решить!

Есть таблица-анкета
-в ней необходимо заполнить все поля. есть какой-то макрос, чтобы проверял заполнены ли эти поля или нет?
-если не заполнены, то выводил бы сообщение.

Например
-не заполнено поле ФИО или Место работы и тд.
-И еще в ячейках В15:F22 нужно сделать проверку: Если в диапазоне В15:F15 заполнена одна ячейка то все норм, если не заполнена ни одна то сообщение.

Заранее благодарю всех, кто откликнется

@Zeag · 28.04.2021, 13:49

Visual Basic
1
Cells(1,1) = ShortFIO

@Olesya-lisa89 · 28.04.2021, 14:21 **[ТС]**

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Sub pdf()
 
'проверка стоит ли оценка
 
 
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=(ActiveWorkbook.Path & "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".pdf"), Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
 
 
 
End Sub

Вот часть моего кода. Мне нужно чтобы в ячейке С5 Осталось неизменным ФИО(Иванов Иван Иванович) а файл pdf сохранялся как Иванов И.И

Добавлено через 1 минуту
плюс еще делает кидает в архив и отправляет на почту

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub RARиПочта()
 
 
 
Dim Ret
 
    
    Ret = IsFileOpen(ActiveWorkbook.Path & "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".pdf")
    If Ret = True Then
        MsgBox "Ошибка! Закройте Анкету"
     Exit Sub
    End If
Dim RetVal
   Dim WinRarApp$, iFileName$, iArhivName$, adr$, iPath$
     
   WinRarApp$ = ActiveWorkbook.Path & "\service\WinRAR.exe a -p123 -ep "
   
   iPath = ActiveWorkbook.Path & "" 'Обращается к папке где лежит эксель
   iFileName$ = "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".pdf"   'ищет pdf"
   iArhivName$ = "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".rar"
   adr$ = WinRarApp$ & " """ & iPath & iArhivName$ & """ """ & iPath & iFileName$ & """ "
   RetVal = shell(adr$, vbHide) 'vbNormalFocus)
Set objOL = CreateObject("Outlook.Application")
Set objMail = objOL.CreateItem(0)
With objMail
.To = "Selezneva_OO@orene.ru"
'.CC = ""                                        'адрес получателя копии
'.Body = InputBox("Введите текст письма")            'текст письма
.Subject = Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".rar"                          'тема письма
 
.Attachments.Add ActiveWorkbook.Path & "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".rar"  'путь к файлу"
'If MsgBox("Вы уверены, что хотите отправить?", vbYesNo, "Предупреждение") = vbNo Then Exit Sub 'или =7
    'Selection.ClearContents
.Send
MsgBox "Письмо отправленно"
End With
Set objMail = Nothing
Set objOL = Nothing
'Удяляейм pdf из папки
Kill (ActiveWorkbook.Path & "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".pdf")
End Sub
 
Function IsFileOpen(FileName As String)
    Dim pdf As Long, ErrNo As Long
 
    On Error Resume Next
    pdf = FreeFile()
    Open FileName For Input Lock Read As #pdf
    Close pdf
    ErrNo = Err
    On Error GoTo 0
 
    Select Case ErrNo
    Case 0:    IsFileOpen = False
    Case 70:   IsFileOpen = True
    Case Else: Error ErrNo
    End Select
End Function

вот вся сложность для меня это сделать чтоб pdf сохранял фамилия и инициалы

@Zeag · 28.04.2021, 15:43

В вашем коде не совсем понял, в какой ячейке сидит полное ФИО и в какой строке, какой части ее нужно получить фамилию с инициалами. Если вы хотите вложить файл с полным ФИО в письмо в виде фамилии с инициалами, то нужно переименовать файл сперва.
Далее, запускать по Shell не советую - исполнение пойдет дальше, а RAR будет трудиться, создавая архив. Лучше через WSHell.Run, где можно задать ожидание завершения процесса. Пример выдрал из программы:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
   Dim WSH As Object
   Dim waitOnReturn As Boolean: waitOnReturn = True   ' Wait till end
   Dim windowStyle As Integer: windowStyle = 0        ' Hide window
   Dim URL As String, tStart As Single
 
   If Dir(ThisWorkbook.path & "\wget.exe") = "" Then
      MsgBox "Нет файла wget.exe", vbCritical + vbOKOnly, "Проблема!"
      Exit Sub
   End If
   
   Set WSH = VBA.CreateObject("WScript.Shell")
   URL = "https://suppliers-stats.wildberries.ru/api/v1/supplier/stocks?dateFrom=2020-05-29&key=" & YKey
 
   Application.StatusBar = "Соединение с сайтом..."
   Application.ScreenUpdating = False
   tStart = Timer
   WSH.Run Chr(34) & ThisWorkbook.path & "\wget.exe" & Chr(34) & " -O " & Chr(34) & ThisWorkbook.path & "\wild" & Chr(34) & " " & URL, windowStyle, waitOnReturn
   Set WSH = Nothing
   Application.StatusBar = "Время " & Timer - tStart

И еще используйте теги VB на панели инструментов, чтобы ваш код был оформлен и выглядел понятнее.

@Zeag · 28.04.2021, 15:52

Если я правильно понял, вот так надо?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
Sub RARиПочта()
   Dim Ret, RetVal, WinRarApp$, iFileName$, iArhivName$, adr$, iPath$
 
   Ret = IsFileOpen(ActiveWorkbook.Path & "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".pdf")
   If Ret = True Then
      MsgBox "Ошибка! Закройте Анкету"
      Exit Sub
   End If
 
   WinRarApp$ = ActiveWorkbook.Path & "\service\WinRAR.exe a -p123 -ep "
 
   iPath = ActiveWorkbook.Path & "" 'Обращается к папке, где лежит эксель
   iFileName$ = "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".pdf" 'ищет pdf"
   iArhivName$ = "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".rar"
   adr$ = WinRarApp$ & " """ & iPath & iArhivName$ & """ """ & iPath & iFileName$ & """ "
   RetVal = Shell(adr$, vbHide) 'vbNormalFocus)
 
   Set objOL = CreateObject("Outlook.Application")
   Set objMail = objOL.CreateItem(0)
   With objMail
      .To = "Selezneva_OO@orene.ru"
      '.CC = "" 'адрес получателя копии
      '.Body = InputBox("Введите текст письма") 'текст письма
      .Subject = Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".rar" 'тема письма
      .Attachments.Add ActiveWorkbook.Path & "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".rar" 'путь к файлу"
      'If MsgBox("Вы уверены, что хотите отправить?", vbYesNo, "Предупреждение") = vbNo Then Exit Sub 'или =7
      'Selection.ClearContents
      .Send
      MsgBox "Письмо отправлено"
   End With
 
   Set objMail = Nothing
   Set objOL = Nothing
   'Удяляем pdf из папки
   Kill (ActiveWorkbook.Path & "" & Range("C5") & "_" & "Анкета" & "_" & Range("I7") & ".pdf")
End Sub
 
Function IsFileOpen(FileName As String)
   Dim pdf As Long, ErrNo As Long
 
   On Error Resume Next
   pdf = FreeFile()
   Open FileName For Input Lock Read As #pdf
   Close pdf
   ErrNo = Err
   On Error GoTo 0
 
   Select Case ErrNo
      Case 0: IsFileOpen = False
      Case 70: IsFileOpen = True
      Case Else: Error ErrNo
   End Select
End Function
 
Sub pdf()
   Dim ShortName As String, xSpl() As String
 
   xSpl = Split(Range("C5"), " ")
   ShortName = xslp(0) & " " & Left(xslp(1), 1) & "." & Left(xslp(2), 1) & "."
   'проверка стоит ли оценка
   ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=(ActiveWorkbook.Path & "" & ShortName & "_" & "Анкета" & "_" & Range("I7") & ".pdf"), _
         Quality:=xlQualityStandard, IncludeDocProperties:=False, _
         IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

@Olesya-lisa89 · 29.04.2021, 13:28 **[ТС]**

Спасибо большое!

Новые блоги и статьи Все статьи Все блоги /
ИИ не может найти нужный язык в списке Supersumestria 05.10.2026 Я ему даю вот такое изображение и прошу найти и подчеркнуть немецкий язык. Возвращает он вот это: https:/ / i. **********/ vqBWLe2. png Нужную строчку в 3й колонке просто выдумал. . Это. . .	Новая последняя моя музыка в SUNO zorxor 05.10.2026 Здравствуйте, дорогие мои друзья! С большой радостью я хотел бы представить вам свою новую последнею музыку, которую сгенерировала мне по моей просьбе нейросеть SUNO. С уважением, zorxor. Это. . .	Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .	Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .
Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .	Запрет дублирования строк в табличной части Maks 13.09.2026 Реализация из решения ниже выполнена на нетиповом справочнике "Нормы ТО" с табличной часть "Виды ТО", разработанного в КА2, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .	Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .	Программа опроса у.з. расходомера SLS-720F Argus19 02.09.2026 Программа опроса у. з. расходомера SLS-720F Программа опрашивает один раз в минуту три ультразвуковых расходомера SLS-720F через интерфейс RS-485 по протоколу Modbus RTU. Опрашиваются регистры. . .

@Olesya-lisa89 0 / 0 / 0 Регистрация: 07.11.2018 Сообщений: 130
	29.04.2021, 13:28 [ТС]
	Спасибо большое! 0