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

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

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

Array to rows

 
Sub ArrayToRows1()
    Dim MyArray()
    Dim Rows As Long
    Rows = 5200
    ReDim MyArray(1 To Rows)
    Cells.Clear
    i = 1
    For r = 1 To Rows
        MyArray(r) = i
        i = i + 1
    Next r
    Range(Cells(1, 1), Cells(Rows, 1)) = _
      Application.Transpose(MyArray)
End Sub



Array to rows - method (Limited to

 
Sub ArrayToRows2()
    Dim Rows As Long
    Dim MyArray()
    Rows = 65536
    ReDim MyArray(1 To Rows, 0 To 0)
    Cells.Clear
    i = 1
    For r = 1 To Rows
        MyArray(r, 0) = i
        i = i + 1
    Next r
    Range(Cells(1, 1), Cells(Rows, 1)) = MyArray
End Sub



Bold cells in a Row

 
Public Sub BoldCells()
  Dim Row As Object
  
  For Each Row In Range("SalesData").Rows
    If Row.Cells(1).Value > 1000 Then
      Row.Font.Bold = True
    Else
      Row.Font.Bold = False
    End If
  Next Row
End Sub



change row height

 
Private Sub ChangeRowHeight(Height As Variant)
    If IsNumeric(Height) Then
        If Height > 0 And Height < 100 Then
            Me.Rows.RowHeight = Height
        ElseIf Height = 0 Then
            Me.Rows.RowHeight = Me.StandardHeight
        End If
    End If
End Sub



Clearing a range differs from deleting a range. When you delete a range, Excel shifts the remaining cells around to fill up the range you deleted.

 
Sub delete()
    Rows("6:6").delete
End Sub



Delete empty rows

 
Sub DeleteEmptyRows()
  Dim rngRow As Range
  For Each rngRow In ActiveSheet.UsedRange.Rows
    If WorksheetFunction.CountA(rngRow) = 0 Then
      rngRow.EntireRow.Delete
    End If
  Next rngRow
End Sub



Get the last row and last cell

 
Sub LastCell()
  Dim rngLast As Range
  Dim LastRow As Long, LastCol As Long
  
  Set rngLast = Range("A1").SpecialCells(xlCellTypeLastCell)
  LastRow = rngLast.Row
  LastCol = rngLast.Column
  MsgBox LastRow & " " & LastCol
End Sub



Is in last row

 
Function LASTINROW(rngInput As Range) As Variant
    Dim WorkRange As Range
    Dim i As Integer, CellCount As Integer
    Application.Volatile
    Set WorkRange = rngInput.Rows(1).EntireRow
    Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
    CellCount = WorkRange.Count
    For i = CellCount To 1 Step -1
        If Not IsEmpty(WorkRange(i)) Then
            LASTINROW = WorkRange(i).Value
            Exit Function
        End If
    Next i
End Function



returns a number that represents the last nonempty cell in the same row

 
Function GetLastUsedColumn(rg As Range) As Long 
    Dim lMaxColumns As Long 
    lMaxColumns = ThisWorkbook.Worksheets(1).Columns.Count 
    If IsEmpty(rg.Parent.Cells(rg.Row, lMaxColumns)) Then 
        GetLastUsedColumn = _ 
            rg.Parent.Cells(rg.Row, lMaxColumns).End(xlToLeft).Column 
    Else 
        GetLastUsedColumn = rg.Parent.Cells(rg.Row, lMaxColumns).Column 
    End If 
End Function



Select active row

 
Sub SelectActiveRow()
    If IsEmpty(ActiveCell) Then Exit Sub
    On Error Resume Next
    If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft)
    If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else Set RightCell = ActiveCell.End(xlToRight)
    Range(LeftCell, RightCell).Select
End Sub



Select entire row

 
Sub SelectEntireRow()
    Selection.EntireRow.Select
End Sub



Select first to last row

 
Sub SelectFirstToLastInRow()
    Set LeftCell = Cells(ActiveCell.Row, 1)
    Set RightCell = Cells(ActiveCell.Row, 256)
    If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
    If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
    If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select
End Sub



Set the color row by row

 
Sub ColorCells3()
   Dim myRange As Range
   Dim i As Long
  
   Set myRange = Range("A1:E5")
   For i = 1 To myRange.Cells.Count
      If myRange(i).Value < 100 Then
         myRange(i).Font.ColorIndex = 6
      Else
        myRange(i).Font.ColorIndex = 1
      End If
   Next i
End Sub