Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Выводить в конце цикла информацию о возникших ошибках
 
#1
29.10.2015 09:06:57
Есть макрос который перебирает ФИО из списка и производит ряд действий в зависимости от выбранного ФИО. А именно фильтрует по ФИО в сводной и копирует сводную на новый лист с названием листа (соответствующему ФИО).

Что нужно прописать, чтобы после завершении работы макроса выводилось сообщение о том какие ФИО оказались ошибочными и по ним не создались листы и таблицы?

Заранее благодарю.
Код
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
Изменено: kornilcdima - 29.10.2015 11:24:14
 
 
 
#2
29.10.2015 09:19:19
можно так

Код
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
 
 
 
#3
29.10.2015 09:19:32
Например так, развивайте как хотите:
Код
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, то несовпавших можно вывести всех сразу в одном месиджбоксе.
Ну а если их например сотня или две или тысяча? Нам это неизвестно, поэтому развивайте сами...
Изменено: Hugo - 29.10.2015 09:22:50
 
 
 
#4
29.10.2015 09:55:00
Спасибо большое за решение
 
 
 
Страницы: 1
Наверх