1) Filling table with given size with next numbers
2) Changing some data in the table, u must also give size of table
3) Copying data from Column 1 and paste it into table
4) Building two dimensions array
5) Building two dimensiona array which works as vlookup to send email to recipient
6) Loop Do ... Until ...
7) Loop For Each ... Next
8) Loop For ... Next
9) Loop Do While... Loop
10) Select Case
1) Filling table with given size with next numbers
Sub LoopExample_1()
Dim col, row, r, number As Integer
ActiveSheet.UsedRange.Clear ' cleans sheet from all data
number = InputBox("Give me number of Columns and Rows")
r = 1
For row = 1 To number Step 1
For col = 1 To number Step 1
Cells(row, col) = r
r = r + 1
Next col
Next row
End Sub
2) Changing some data in the table, u must also give size of table
Sub LoopExample_2()
Dim col, row, r, number As Integer
number = InputBox("Give me number of Columns and Rows")
For row = 1 To number Step 1
For col = 1 To number Step 1
If Cells(row, col).Value = 10 Then Cells(row, col) = "XX"
Next col
Next row
End Sub
3) Copying data from Column 1 and paste it into table
Sub LoopExample_3()
Dim col, row, row1 As Integer
row = 1
Number = ActiveSheet.UsedRange.Rows.Count
For row1 = 1 To Sqr(Number) + 1
For col = 6 To 6 + Sqr(Number) + 1
Cells(row, 1).Copy
Cells(row1, col).PasteSpecial
If row = Number Then GoTo finish
row = row + 1
Next col
Next row1
finish:
End Sub
Letters from Column A were pasted in the rows starting from A1 to I3
4) Building two dimensions array
Sub TwoDimensionArray()
x = 1
Row = InputBox("input rows number")
Col = InputBox("input col's numner")
Dim a() As Variant
ReDim Preserve a(Row - 1, Col - 1)
For i = 0 To Row - 1
For j = 0 To Col - 1
a(i, j) = x
x = x + 1
Next
Next
For i = LBound(a, 1) To UBound(a, 1)
For j = LBound(a, 2) To UBound(a, 2)
MsgBox a(i, j)
Next
Next
End Sub
5) Building two dimensiona array which works as vlookup to send email to recipient
Sub TwoDimensionArray()
number = Cells(1, 1)
Dim WB As Excel.Workbook
Set WB = Workbooks.Open("C:\Users\myname\Desktop\file.xlsx")
Row = ActiveSheet.UsedRange.Columns.Count
Col = ActiveSheet.UsedRange.Rows.Count
Dim a() As Variant
ReDim Preserve a(Row - 1, Col - 1)
For i = 0 To Row - 1
For j = 0 To Col - 1
a(i, j) = Cells(j + 1, i + 1)
Next
Next
For i = LBound(a, 1) To UBound(a, 1)
For j = LBound(a, 2) To UBound(a, 2)
If number = a(i, j) Then
GoTo end_of_for
End If
Next
Next
end_of_for:
Workbooks("file.xlsx").Close SaveChanges:=False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = (a(i + 1, j))
.CC = ""
.BCC = ""
.Subject = "Subject "
.Body = "Text"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
6) Loop Do ... Until ...
Sub Do_Loop_Until() Dim one As Integer one = 0 Do
MsgBox (one)
one = one + 1
Loop Until one > 10 End Sub
7) Loop For Each ... Next
Sub For_Each_Next() Table = Array(1, 2, 3, 4) For Each element In Table MsgBox (element) Next End Sub
8) Loop For ... Next
Sub For_Next()
For i = 1 To 10
MsgBox (i)
Next i
End Sub
9) Loop Do While... Loop
Sub Do_While_Loop()
one = 0
Do While one < 10
MsgBox (one)
one = one + 1
Loop
End Sub
10) Select Case
Sub Select_case()
Dim number As Integer
number = InputBox("Give me some number")
Select Case number
Case 1 To 5
MsgBox "1 to 5"
Case 6, 7, 8
MsgBox "6 to 7"
Case 9 To 10
MsgBox "9 or 10"
Case Else
MsgBox "Other"
End Select
End Sub
OneDimensionArray
Sub OneDimensionArray()
x = 1
Row = ActiveSheet.UsedRange.Rows.Count
Dim a() As Variant
ReDim Preserve a(Row - 1)
For i = 0 To Row - 1
a(i) = x
x = x + 1
Next
For i = LBound(a) To UBound(a)
MsgBox a(i)
Next
End Sub
OneDimensionArray plus reading cells
Sub OneDimensionArray()
Row = ActiveSheet.UsedRange.Rows.Count
Dim a() As Variant
ReDim Preserve a(Row - 1)
For i = 0 To Row - 1
a(i) = Cells(i + 1, 1)
Next
For i = LBound(a) To UBound(a)
MsgBox a(i)
Next
End Sub
OneDimensionArray plus building array with unique values
Sub OneDimensionArray()
Row = ActiveSheet.UsedRange.Rows.Count
Dim a() As Variant
ReDim Preserve a(Row - 1)
For i = 0 To Row - 1
If i > 0 Then
Table = a()
For Each element In Table
If Cells(i + 1, 1) = (element) Then
x = Cells(i + 1, 1)
End If
Next
End If
If x = Cells(i + 1, 1) Then GoTo 1
a(i) = Cells(i + 1, 1)
1:
x = Null
Next
Table = a()
Y = 0
Z = 0
For Each element In Table
If IsEmpty(element) Then
Z = Z + 1
Else: Y = Y + 1
End If
Next
MsgBox "with value " & (Y) & vbNewLine & "empty " & (Z)
Dim b() As Variant
ReDim Preserve b(Y - 1)
i = 0
Table = a()
For Each element In Table
If IsEmpty(element) Then
Else: b(i) = (element)
i = i + 1
End If
Next
Table = b()
For Each element In Table
MsgBox (element)
Next
Erase a, b
End Sub