в 16:33, 26 мая 2010

2010-05-26T16:33:00Z

Admin: 1 версия

2010-05-26T12:47:25Z

1 версия

Новая страница

==A better way to write to a range:Filling a range==



<source lang="vb">

Sub LoopFillRange()
Dim CurrRow As Long, CurrCol As Integer
Dim CurrVal As Long
CellsDown = 3
CellsAcross = 4
StartTime = timer
CurrVal = 1
Application.ScreenUpdating = False
For CurrRow = 1 To CellsDown
For CurrCol = 1 To CellsAcross
ActiveCell.Offset(CurrRow - 1, _
CurrCol - 1).value = CurrVal
CurrVal = CurrVal + 1
Next CurrCol
Next CurrRow
" Display elapsed time
Application.ScreenUpdating = True
MsgBox Format(timer - StartTime, "00.00") & " seconds"
End Sub
</source>

==Get the last cell==



<source lang="vb">

Sub GetLastCell()
Dim RealLastRow As Long
Dim RealLastColumn As Long

Range("A1").Select
On Error Resume Next
RealLastRow = Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
RealLastColumn = Cells.Find("*", Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
Cells(RealLastRow, RealLastColumn).Select
End Sub
</source>

==Is a cell empty==



<source lang="vb">

Sub ShadeEverySecondRow()
Dim i As Integer
i = 2
Do Until IsEmpty(Cells(i, 1))
Cells(i, 1).EntireRow.Interior.ColorIndex = 15
i = i + 2
Loop
End Sub
</source>

==Magic Squares==



<source lang="vb">

Private Sub AssignValueCell()
Dim row1 As Integer
Dim row2 As Integer
Dim row3 As Integer
Dim col1 As Integer
Dim col2 As Integer
Dim col3 As Integer
Dim diagonal1 As Integer
Dim diagonal2 As Integer
row1 = Cells(3, "B").Value + Cells(3, "C").Value + Cells(3, "D").Value
col1 = Cells(3, "B").Value + Cells(4, "B").Value + Cells(5, "B").Value
diagonal1 = Cells(3, "B").Value + Cells(4, "C").Value + Cells(5, "D").Value
Cells(6, "B").Value = col1
Cells(3, "E").Value = row1
Cells(6, "E").Value = diagonal1
End Sub
</source>

==Moving the pointer to the cell containing the greatest value==



<source lang="vb">

Sub GoToMax()
Dim WorkRange As range
If TypeName(Selection) <> "Range" Then Exit Sub
If Selection.Count = 1 Then
Set WorkRange = Cells
Else
Set WorkRange = Selection
End If
MaxVal = Application.Max(WorkRange)
On Error Resume Next
WorkRange.Find(What:=MaxVal, _
After:=WorkRange.range("A1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False _
).Select
If Err <> 0 Then MsgBox "Max value was not found: " _
& MaxVal
End Sub
</source>

==Nest If statement in Do Loop Until for cells==



<source lang="vb">

Sub m()
Dim I As Integer
I = 1
Do
If (Cells(I, "A").Value = "A") Then
MsgBox ("I found a A in row " & Str(I))
End If
I = I + 1
Loop Until (Cells(I, "A").Value = "")
End Sub
</source>

==Nest If statement in Do Loop While with comparison operators==



<source lang="vb">

Sub IfDo()
Dim I As Integer
I = 1
Do
If (Cells(I, "A").Value = "A") Then
MsgBox ("I found a A in row " & Str(I))
End If
I = I + 1
Loop While (Cells(I, "A").Value <> "")
End Sub
</source>

==Selects cell G4==



<source lang="vb">

Sub sel()
range("G4").Select
End Sub
</source>

==Transposing is taking a rectangular block of data and rotating it so that columns become rows and vice versa.==



<source lang="vb">

Public Sub Transpose()
Dim I As Integer
Dim J As Integer
Dim transArray() As Variant
Dim numRows As Integer
Dim numColumns As Integer
Dim colIndex As Integer
Dim rowIndex As Integer
Dim inputRange As Range
Set inputRange = ActiveWindow.Selection
colIndex = inputRange.Column
rowIndex = inputRange.Row
numRows = inputRange.Rows.Count
numColumns = inputRange.Columns.Count
ReDim transArray(numRows - 1, numColumns - 1)
For I = colIndex To numColumns + colIndex - 1
For J = rowIndex To numRows + rowIndex - 1
transArray(J - rowIndex, I - colIndex) = Cells(J, I).Value
Next J
Next I
inputRange.ClearContents
For I = colIndex To numRows + colIndex - 1
For J = rowIndex To numColumns + rowIndex - 1
Cells(J, I).Value = transArray(I - colIndex, J - rowIndex)
Next J
Next I
Cells(rowIndex, colIndex).Select
End Sub
</source>

==Use arrays to fill ranges faster==



<source lang="vb">

Sub ArrayFillRange()
Dim TempArray() As Integer
Dim TheRange As range
CellsDown = 3
CellsAcross = 4
StartTime = timer
ReDim TempArray(1 To CellsDown, 1 To CellsAcross)
Set TheRange = ActiveCell.range(Cells(1, 1), Cells(CellsDown, CellsAcross))
CurrVal = 0
Application.ScreenUpdating = False
For I = 1 To CellsDown
For J = 1 To CellsAcross
TempArray(I, J) = CurrVal + 1
CurrVal = CurrVal + 1
Next J
Next I
TheRange.value = TempArray
Application.ScreenUpdating = True
MsgBox Format(timer - StartTime, "00.00") & " seconds"
End Sub
</source>

==Uses nested For/Next loops to count the total number of cells used in all open worksheets:==



<source lang="vb">

Public Sub numCells()
Dim I As Integer
Dim K As Integer
Dim numCells As Long
For K = 1 To Workbooks.Count "Loop through workbooks
Workbooks(K).Activate
For I = 1 To Worksheets.Count "Loop through worksheets
numCells = numCells + Worksheets(I).UsedRange.Count
Next I
Next K
MsgBox (numCells)
End Sub
</source>

← Предыдущая	Версия 16:33, 26 мая 2010
(нет различий)

VBA/Excel/Access/Word/Excel/Cell - История изменений

в 16:33, 26 мая 2010

Admin: 1 версия