Макрос на офомление

[mephist]

Хочу написать макрос, которой бы работал следующим образом:
я выбираю произвольный диапозон, выполняю макрос, он рисует границу таблицы, линии между ячейками, и выделяет разными цветами верхнюю и нижнии строки,и левый столбец.
Основная проблема состоит в то, чтобы диапозон был произвольных размеров.
Как это сделать??? (я если честно вообще не представляю)
примерно мой код выглядит так. (записывал мастером записи)
Sub format()
'
' format макрос
'

'
Selection.Borders(xlDiagonalDown).L ineStyle = xlNone
Selection.Borders(xlDiagonalUp).Lin eStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
ActiveCell.Range("A1:H1").Select
With Selection.Font
.Name = "Calibri"
.FontStyle = "îáû÷íûé"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Selection.Borders(xlDiagonalDown).L ineStyle = xlNone
Selection.Borders(xlDiagonalUp).Lin eStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
ActiveCell.Offset(1, 0).Range("A1:A7").Select
Selection.Borders(xlDiagonalDown).L ineStyle = xlNone
Selection.Borders(xlDiagonalUp).Lin eStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.399945066682943
.PatternTintAndShade = 0
End With
ActiveCell.Offset(7, 0).Range("A1:H1").Select
Selection.Borders(xlDiagonalDown).L ineStyle = xlNone
Selection.Borders(xlDiagonalUp).Lin eStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
End Sub

[EducatedFool]

Попробуйте такой макрос:

Sub FormatSelection()
    Dim ra As Range: Set ra = Selection: Application.ScreenUpdating = False
    If ra.Columns.Count = 1 Or ra.Rows.Count < 3 Then MsgBox "Диапазон не выделен", vbExclamation: Exit Sub
    SetRangeBorders ra, xlContinuous, xlMedium
    ra.Columns(1).Interior.ColorIndex = 7 ' первый столбец
    ra.Rows(1).Interior.ColorIndex = 3: ra.Rows(ra.Rows.Count).Interior.ColorIndex = 4
End Sub

Sub SetRangeBorders(ByRef ra As Range, ByVal BordersLineStyle As XlLineStyle, ByVal BordersWeight As XlBorderWeight)
    ra.Borders.LineStyle = BordersLineStyle: ra.Borders.Weight = BordersWeight
    ra.Borders(xlDiagonalDown).LineStyle = xlNone: ra.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub

Перед запуском макроса FormatSelection выделите диапазон ячеек на листе (не меньше 3 строк и 2 столбцов)

Цвета можете подобрать здесь: http://www.programmersforum.ru/showp...46&postcount=9

[mephist]

Все супер! Круто! Работает! СПАСИБО БОЛЬШОЕ!
Честно признаюсь, я совсем не знаю синтаксиса VB, но вот что я написал. Вообще работает, но проверьте, пожалуйста на ошибки, помарки и тупости. Буду рад любым коментам.
Sub FormatSelection()

Dim ra As Range: Set ra = Selection: Application.ScreenUpdating = False
If ra.Columns.Count = 1 Or ra.Rows.Count < 3 Then MsgBox "Не выделен диапазон", vbExclamation: Exit Sub
SetRangeBorders ra, xlContinuous, xlThick
ra.Columns(1).Interior.ColorIndex = 41: ra.Columns(1).Font.Name = "Calibri"
ra.Rows(1).Interior.ColorIndex = 49:
ra.Rows(1).Select
With Selection.Font
.Name = "Calibri"
.FontStyle = "курсив"
.Size = 11
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
ra.Rows(1).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
ra.Rows(ra.Rows.Count).Interior.Col orIndex = 48:
ra.Rows(ra.Rows.Count).Select
With Selection.Font
.Name = "Calibri":
.FontStyle = "полужирный":
.Size = 11
End With
Columns("ra.Columns(1):ra.Columns(r a.Columns.Count)").EntireColumn.Aut oFit
End Sub

Sub SetRangeBorders(ByRef ra As Range, ByVal BordersLineStyle As XlLineStyle, ByVal BordersWeight As XlBorderWeight)
ra.Borders.LineStyle = BordersLineStyle: ra.Borders.Weight = BordersWeight
ra.Borders(xlDiagonalDown).LineStyl e = xlNone: ra.Borders(xlDiagonalUp).LineStyle = xlNone
ra.Borders(xlInsideVertical).LineSt yle = xlContinuous: ra.Borders(xlInsideVertical).Weight = xlThin
ra.Borders(xlInsideHorizontal).Line Style = xlContinuous: ra.Borders(xlInsideHorizontal).Weig ht = xlThin
ra.Rows(1).Borders(xlEdgeBottom).Li neStyle = xlContinuous: ra.Rows(1).Borders(xlEdgeBottom).We ight = xlMedium
ra.Columns(1).Borders(xlEdgeRight). LineStyle = xlContinuous: ra.Columns(1).Borders(xlEdgeRight). Weight = xlMedium
ra.Rows(ra.Rows.Count).Borders(xlEd geTop).LineStyle = xlContinuous: ra.Rows(ra.Rows.Count).Borders(xlEd geTop).Weight = xlMedium
End Sub

А вот эта строка совсем не работает,помогите исправить:
Columns("ra.Columns(1):ra.Columns(r a.Columns.Count)").EntireColumn.Aut oFit

[EducatedFool]

По сути, Вы всё сделали правильно.

Убрал немного лишнего (в частности, всякие Select-ы)

Sub FormatSelection()
    Dim ra As Range: Set ra = Selection: Application.ScreenUpdating = False
    If ra.Columns.Count = 1 Or ra.Rows.Count < 3 Then MsgBox "Не выделен диапазон", vbExclamation: Exit Sub
    SetRangeBorders ra, xlContinuous, xlThick
    ra.Columns(1).Interior.ColorIndex = 41: ra.Columns(1).Font.Name = "Calibri"
    With ra.Rows(1)
        .Interior.ColorIndex = 49
        .Font.Name = "Calibri": .Font.Bold = True: .Font.Size = 11
        '.Font.ThemeColor = xlThemeColorDark1:    .Font.ThemeFont = xlThemeFontMinor ' только для Excel 2007
        .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    With ra.Rows(ra.Rows.Count)
        .Font.Name = "Calibri": .Font.Bold = True: .Font.Size = 11
        .Interior.ColorIndex = 48:
    End With
    ra.EntireColumn.AutoFit
End Sub

Sub SetRangeBorders(ByRef ra As Range, ByVal BordersLineStyle As XlLineStyle, ByVal BordersWeight As XlBorderWeight)
    ra.Borders.LineStyle = BordersLineStyle: ra.Borders.Weight = BordersWeight
    ra.Borders(xlDiagonalDown).LineStyle = xlNone: ra.Borders(xlDiagonalUp).LineStyle = xlNone
    ra.Borders(xlInsideVertical).LineStyle = xlContinuous
    ra.Borders(xlInsideVertical).Weight = xlThin
    ra.Borders(xlInsideHorizontal).LineStyle = xlContinuous
    ra.Borders(xlInsideHorizontal).Weight = xlThin
    ra.Rows(1).Borders(xlEdgeBottom).LineStyle = xlContinuous
    ra.Rows(1).Borders(xlEdgeBottom).Weight = xlMedium
    ra.Columns(1).Borders(xlEdgeRight).LineStyle = xlContinuous
    ra.Columns(1).Borders(xlEdgeRight).Weight = xlMedium
    ra.Rows(ra.Rows.Count).Borders(xlEdgeTop).LineStyle = xlContinuous
    ra.Rows(ra.Rows.Count).Borders(xlEdgeTop).Weight = xlMedium
End Sub

PS: На будущее - выделяйте код специальным тегом (значок #), чтобы потом не приходилось вручную удалять из него лишние пробелы.

[mephist]

Спасибо большое. Все супер!
А можете помочь с модификацией?
Я хочу, чтобы макрос искал в первом столбце определенное слово и выделял цветом все стороки, которые содержат это слово.
Есть какая-нибудь функция поиска???
или
подскажите как в VB организуется цикл и считывание информации из ячейки???

[EducatedFool]

макрос искал в первом столбце определенное слово и выделял цветом все стороки, которые содержат это слово.

А не проще ли для этого использовать условное форматирование?
Назначить условное форматирование можно и макросом:

Sub test2()
    txt = "слово"
    Range("a1:a100").FormatConditions.Delete
    Range("a1:a100").FormatConditions.Add xlCellValue, xlEqual, "=""" & txt & """"
    Range("a1:a100").FormatConditions(1).Interior.Color = vbRed
End Sub

подскажите как в VB организуется цикл и считывание информации из ячейки???

Sub test()
    Dim cell As Range, ra As Range: Application.ScreenUpdating = False
    Set ra = Range([A1], Range("A" & Rows.Count).End(xlUp))
    For Each cell In ra.Cells
        If cell = "слово" Then cell.Interior.Color = vbGreen
        If cell Like "*ДругоеСлово*" Then cell.Font.Color = vbRed
    Next cell
End Sub

[mephist]

Маленький вопросик:
происходит сверка содержимого ячейки и "слова" или поиск слова в содержимом ячейки. Проще говоря хочется, если в ячейке находится
"\\слово", то она тоже выделяется.

[EducatedFool]

Sub test()
    txt = "слово"
    Dim cell As Range, ra As Range: Application.ScreenUpdating = False
    Set ra = Range([A1], Range("A" & Rows.Count).End(xlUp))
    For Each cell In ra.Cells
        If cell Like "*" & txt & "*" Then cell.Interior.Color = vbGreen
    Next cell
End Sub

[mephist]

EducatedFool огромное спасибо!!! Выручил грандиозно!!!
Но вот самой последний штрих в макрос я так и не понял, и не доделал
Целиком он теперь выглядит так:

Sub FormatSelection()
    Dim ra As Range: Set ra = Selection: Application.ScreenUpdating = False
    If ra.Columns.Count = 1 Or ra.Rows.Count < 3 Then MsgBox "Диапазон не выделен", vbExclamation: Exit Sub
    SetRangeBorders ra, xlContinuous, xlThick
    ra.Columns(1).Interior.ColorIndex = 41: ra.Columns(1).Font.Name = "Calibri"
    With ra.Rows(1)
        .Interior.ColorIndex = 49
        .Font.Name = "Calibri": .Font.Bold = True: .Font.Size = 11: .Font.FontStyle = "курсив"
    End With
    With ra.Rows(ra.Rows.Count)
        .Font.Name = "Calibri": .Font.Bold = True: .Font.Size = 11
        .Interior.ColorIndex = 48:
    End With
    ra.EntireColumn.AutoFit
End Sub

Sub SetRangeBorders(ByRef ra As Range, ByVal BordersLineStyle As XlLineStyle, ByVal BordersWeight As XlBorderWeight)
    ra.Borders.LineStyle = BordersLineStyle: ra.Borders.Weight = BordersWeight
    ra.Borders(xlDiagonalDown).LineStyle = xlNone: ra.Borders(xlDiagonalUp).LineStyle = xlNone
    ra.Borders(xlInsideVertical).LineStyle = xlContinuous:    ra.Borders(xlInsideVertical).Weight = xlThin
    ra.Borders(xlInsideHorizontal).LineStyle = xlContinuous:    ra.Borders(xlInsideHorizontal).Weight = xlThin
    ra.Rows(1).Borders(xlEdgeBottom).LineStyle = xlContinuous:    ra.Rows(1).Borders(xlEdgeBottom).Weight = xlMedium
    ra.Columns(1).Borders(xlEdgeRight).LineStyle = xlContinuous:    ra.Columns(1).Borders(xlEdgeRight).Weight = xlMedium
    ra.Rows(ra.Rows.Count).Borders(xlEdgeTop).LineStyle = xlContinuous:   ra.Rows(ra.Rows.Count).Borders(xlEdgeTop).Weight = xlMedium
End Sub

Sub Indention()
    txt1 = "total":    txt2 = "Total"
    Dim cell As Range, ra As Range: Application.ScreenUpdating = False
    Set ra = Range([A1], Range("A" & Rows.Count).End(xlUp))
    For Each cell In ra.Cells
        If cell Like "*" & txt1 & "*" Then cell.Interior.Color = vbGreen
        If cell Like "*" & txt2 & "*" Then cell.Interior.Color = vbRed
    Next cell
End Sub

FormatSelection и SetRangeBorders работают отменно. А вот Indention не работает вообще. Мне кажется это из-за переприсвоения ra или Range. Если честно я не разобрался со строкой

Set ra = Range([A1], Range("A" & Rows.Count).End(xlUp))

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

[EducatedFool]

Set ra = Range([A1], Range("A" & Rows.Count).End(xlUp))
Обрабатываются ячейки, начиная с A1, и заканчивая последней заполненной ячейкой в столбце A


Set ra = selection
Обрабатываются ячейки выделенного диапазона


Set ra = Intersect(Selection.EntireRow, ActiveSheet.UsedRange)
Обрабатываются все ячейки в строках, которые захватывает выделение.
К примеру, выделен диапазон b2:g9
Макрос обработает все ячейки в строках со 2-й по 9-ю.


PS: Чтобы не обрабатывать отдельно одни и те же слова, но написанные в разном регистре, используйте директиву Option Compare Text
(эта директива должна стоять первой строкой в модуле, выше всех макросов)

Option Compare Text

Sub Indention()
    txt = "total" ' будут обработаны слова total, Total, toTAL и т.д.
    Dim cell As Range, ra As Range: Application.ScreenUpdating = False
    Set ra = Intersect(Selection.EntireRow, ActiveSheet.UsedRange)
    For Each cell In ra.Cells
        If cell Like "*" & txt & "*" Then cell.Interior.Color = vbGreen
    Next cell
End Sub