Есть макрос который перебирает ФИО из списка и производит ряд действий в зависимости от выбранного ФИО. А именно фильтрует по ФИО в сводной и копирует сводную на новый лист с названием листа (соответствующему ФИО).
Что нужно прописать, чтобы после завершении работы макроса выводилось сообщение о том какие ФИО оказались ошибочными и по ним не создались листы и таблицы?
Заранее благодарю.
Код
Sub new_sh_after()
Dim i As Object
On Error Resume Next
Finalrow = Range("A1048576").End(xlUp).Row
For Each i In Sheets("17").Range("A1:A" & Finalrow)
Err.Clear
Sheets("Pivot").Select
ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("ФИО"). _
ClearAllFilters
ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("ФИО"). _
CurrentPage = i.Value
If Err.Number = 0 Then
Sheets("Pivot").Range(Range("A4"), Range("B4").End(xlDown)).Copy
Worksheets.Add(after:=Worksheets("17")).Name = Left(i, 31)
ActiveSheet.Range("A1").Select
With Selection
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End If
Next i
End Sub
Sub new_sh_after()
Dim i As Object
On Error Resume Next
Finalrow = Range("A1048576").End(xlUp).Row
For Each i In Sheets("17").Range("A1:A" & Finalrow)
Err.Clear
Sheets("Pivot").Select
ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("ФИО"). _
ClearAllFilters
ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("ФИО"). _
CurrentPage = i.Value
If Err.Number = 0 Then
Sheets("Pivot").Range(Range("A4"), Range("B4").End(xlDown)).Copy
Worksheets.Add(after:=Worksheets("17")).Name = Left(i, 31)
ActiveSheet.Range("A1").Select
With Selection
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Else
nm = nm & i.Value & ", "
End If
Next i
MsgBox "Следующих ФИО нет в базе:" & Chr(10) & nm
End Sub
Sub new_sh_after()
Dim i As Object
Dim col As New Collection, el
On Error Resume Next
Finalrow = Range("A1048576").End(xlUp).Row
For Each i In Sheets("17").Range("A1:A" & Finalrow)
Err.Clear
Sheets("Pivot").Select
ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("ФИО"). _
ClearAllFilters
ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("ФИО"). _
CurrentPage = i.Value
If Err.Number = 0 Then
Sheets("Pivot").Range(Range("A4"), Range("B4").End(xlDown)).Copy
Worksheets.Add(after:=Worksheets("17")).Name = Left(i, 31)
ActiveSheet.Range("A1").Select
With Selection
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Else
col.Add i.Value
End If
Next i
For Each el In col
MsgBox el
Next
End Sub
По сообщению - если всего фио будет максимум 20, то несовпавших можно вывести всех сразу в одном месиджбоксе. Ну а если их например сотня или две или тысяча? Нам это неизвестно, поэтому развивайте сами...