VBA/Excel/Access/Word/Excel/Cell Format — различия между версиями

Материал из VB Эксперт
Перейти к: навигация, поиск
м (1 версия)
 
(нет различий)

Версия 16:33, 26 мая 2010

Color cells

 
Public Sub ColorCells()
  Dim Sales As Range
  Dim i As Long
  Dim j As Long
  
  Set Sales = Range("SalesData")
  For i = 1 To Sales.Rows.Count
    For j = 1 To Sales.Columns.Count
      If Sales.Cells(i, j).Value < 100 Then
        Sales.Cells(i, j).Font.ColorIndex = 3
      Else
        Sales.Cells(i, j).Font.ColorIndex = 1
      End If
    Next j
  Next i
End Sub



Coloring all negative cells" backgrounds red

 
Sub SelectiveColor1()
    If TypeName(Selection) <> "Range" Then Exit Sub
    Const REDINDEX = 3
    Application.ScreenUpdating = False
    For Each Cell In Selection
        If Cell.value < 0 Then
          Cell.Interior.ColorIndex = REDINDEX
        Else
          Cell.Interior.ColorIndex = xlNone
        End If
    Next Cell
End Sub



Color multiple-column ranges

 
Sub SelectiveColor2()
    Dim FormulaCells As range
    Dim ConstantCells As range
    Const REDINDEX = 3
    On Error Resume Next
    Application.ScreenUpdating = False
    Set FormulaCells = Selection.SpecialCells(xlFormulas, xlNumbers)
    Set ConstantCells = Selection.SpecialCells(xlConstants, xlNumbers)
    For Each Cell In FormulaCells
        If Cell.value < 0 Then _
          Cell.Font.ColorIndex = REDINDEX
    Next Cell
    For Each Cell In ConstantCells
        If Cell.value < 0 Then
           Cell.Interior.ColorIndex = REDINDEX
        Else
           Cell.Interior.ColorIndex = xlNone
        End If
    Next Cell
End Sub



Make a Cell font bold based on the cell value

 
Sub valueDemo()
     If ActiveCell.value = 10 Then
        ActiveCell.font.bold = True
     End If
End Sub



Makes cell background red if the value is negative

 
Sub SelectiveColor2()
    Dim FormulaCells As Range
    Dim ConstantCells As Range
    Const REDINDEX = 3
    On Error Resume Next
    Application.ScreenUpdating = False
    Set FormulaCells = Selection.SpecialCells (xlFormulas, xlNumbers)
    Set ConstantCells = Selection.SpecialCells (xlConstants, xlNumbers)
    For Each cell In FormulaCells
        If cell.Value < 0 Then _
          cell.Font.ColorIndex = REDINDEX
    Next cell
    For Each cell In ConstantCells
        If cell.Value < 0 Then
           cell.Interior.ColorIndex = REDINDEX
        Else
           cell.Interior.ColorIndex = xlNone
        End If
    Next cell
End Sub



Make the font in number cell bold

 
Sub BoldNCRows()
  Dim rngRow As Range
  For Each rngRow In Cells.SpecialCells(xlCellTypeConstants, xlNumbers).Rows
    rngRow.Font.Bold = True
  Next rngRow
End Sub



Removes all borders for the selected cells

 
Sub RemoveAllBorders()
  Dim calcModus&, updateModus&, i
  Dim rng As Range, ar As Range
  Dim brd As Border
  If Selection Is Nothing Then Exit Sub
  
  calcModus = Application.Calculation
  updateModus = Application.ScreenUpdating
  Application.Calculation = xlManual
  Application.ScreenUpdating = False
  For Each ar In Selection.Areas   
    For Each rng In ar             
      For Each i In Array(xlEdgeTop, xlEdgeBottom, xlEdgeLeft, xlEdgeRight, xlDiagonalDown, xlDiagonalUp)
        rng.Borders(i).LineStyle = xlLineStyleNone
      Next i
      If rng.Column > 1 Then
        rng.Offset(0, -1).Borders(xlRight).LineStyle = xlLineStyleNone
      End If
      If rng.Column < 256 Then
         rng.Offset(0, 1).Borders(xlLeft).LineStyle = xlLineStyleNone
      End If
      If rng.Row > 1 Then
        rng.Offset(-1, 0).Borders(xlBottom).LineStyle = xlLineStyleNone
      End If
      If rng.Row < 65536 Then
         rng.Offset(1, 0).Borders(xlTop).LineStyle = xlLineStyleNone
      End If
    Next rng
  Next ar
  Application.Calculation = calcModus
  Application.ScreenUpdating = updateModus
End Sub



Set cell color

 
Sub Set_Protection()
    On Error GoTo errorHandler
    Dim myDoc As Worksheet
    Dim cel As Range
    Set myDoc = ActiveSheet
    myDoc.Unprotect
    For Each cel In myDoc.UsedRange
        cel.Locked = True
        cel.Font.ColorIndex = xlColorIndexAutomatic
    Next
    myDoc.Protect
    Exit Sub
    errorHandler:
    MsgBox Error
End Sub



Set data to cell D1 of the selected worksheet. And format its contents with color and borders.

 
Sub cmd()
    Cells(1, "D").Value = "Text"
    Cells(1, "D").Select
    
    With Selection
        .Font.Bold = True
        .Font.Name = "Arial"
        .Font.Size = 72
        .Font.Color = RGB(0, 0, 255)  "Dark blue
        .Columns.AutoFit
        .Interior.Color = RGB(0, 255, 255) "Cyan
        .Borders.Weight = xlThick
        .Borders.Color = RGB(0, 0, 255)  "Dark Blue
    End With
End Sub



Sets just the color of cell C1 to red.

 
Sub cellFont()
    Cells(1, "C").Font.Color = vbRed
End Sub



the font color of all cells in the active worksheet is set to red

 
Sub fontColor()
    Cells.Font.Color = vbRed
End Sub