Страницы: 1
RSS
применение макроса к определенным листам+сокращение фио
 
Здравствуйте, пожалуйста помогите с таким делом, имеется макрос который сокращает фио с Иванов Иван Иванович, до Иванов И.И.
пожалуйста помогите дополнить макрос следующими функциями:
- чтоб он работал с определенным столбцом (например D) всех листов книги содержащим в названии дату например 01.01.2015, 02.01.2015 и т.д.
и что б пропускал строки в которых уже сокращенное фио или нет отчества
Вот макрос:      Заранее благодарна за помощь.

Код
Sub fio()
For Each rcell In Selection.Cells
FullFIO = rcell.Value
fio = Split(Application.WorksheetFunction.Trim(FullFIO), " ")
If UBound(fio) <= 3 Then
ShortFIO = fio(0) & " " & Left(fio(1), 1) & "." & Left(fio(2), 1) & "."
rcell.Value = ShortFIO
End If
Next
End Sub
Изменено: Kate_com - 14.03.2015 19:53:53
 
Так делайте с помощью фильтров и доп.столбцов. Зачем макрос, если вы это не будете делать на постоянной основе?
С уважением,
Федор/Все_просто
 
Извините, наверное я что то не правильно объяснила, мне необходимо что б  он работал постоянно с листами в названии которых есть даты (т.к. в книге содержатся и другие листы), и еще он постоянно ругается на те строки в которых  фио уже в сокращенном варианте, может кто знает как это устранить
 
Помощь придёт быстрее, если Вы покажете файл-пример.
 
В таком случае сделайте пример с хотя бы вымышленными данными. Этот пример должен хотя бы отдаленно повторять структуру искомого файла. Сейчас разбираться с чем-то - это все равно, что разговаривать со стеной.
С уважением,
Федор/Все_просто
 
Благодарю за помощь вот файл
Изменено: Kate_com - 14.03.2015 20:17:11
 
Как-то так:
Код
Sub qq()
Dim ws As Worksheet, ra As Range, rCell As Range, arr() As String
For Each ws In ThisWorkbook.Worksheets                                                      'цикл по листам
    If Right(ws.Name, 4) = "2015" Then                                                      'проверка названия листа
        Set ra = Range(ws.Cells(6, 4), ws.Cells(ws.Cells(Rows.Count, 4).End(xlUp).Row, 4))
        ra = Application.Trim(ra)                                                           'удаление пробелов
        For Each rCell In ra.Cells                                                          'цикл по ячейкам
            arr = Split(rCell)
            If UBound(arr) = 2 Then
                rCell = arr(0) & " " & Left(arr(1), 1) & "." & Left(arr(2), 1) & "."
            End If
        Next rCell
    End If
Next ws
End Sub
Изменено: Alexander88 - 14.03.2015 20:38:17
 
Огромнейшее СПАСИБО, все работает.
Страницы: 1
Наверх