Arrayの練習-1

Option Explicit
‘Option Base は 0か1
‘Option Base 1

Sub SimpleVariables()

    Dim TopFilm As String

    TopFilm = Range("B3").Value

End Sub

Sub FixedSizeArray()

    Dim TopThreeFilms(2) As String

End Sub

Sub FixedSizeArray2()

    Dim TopThreeFilms(3) As String

End Sub

Sub FixedSizeArray3()

    Dim TopThreeFilms(1 To 3) As String

End Sub

Sub FixedSizeArray4()

    Dim TopThreeFilms(1 To 3) As String

    TopThreeFilms(1) = Range("B3").Value
    TopThreeFilms(2) = Range("B4").Value
    TopThreeFilms(3) = Range("B5").Value

End Sub

Sub FixedSizeArray5()

    Dim TopThreeFilms(1 To 3) As String

    TopThreeFilms(1) = Range("B3").Value
    TopThreeFilms(2) = Range("B4").Value
    TopThreeFilms(3) = Range("B5").Value

    Worksheets.Add

    Range("A1") = TopThreeFilms(1)
    Range("A2") = TopThreeFilms(2)
    Range("A3") = TopThreeFilms(3)

End Sub

Sub Erasing_FixedSizeArray5()

    Dim TopThreeFilms(1 To 3) As String

    TopThreeFilms(1) = Sheet1.Range("B3").Value
    TopThreeFilms(2) = Sheet1.Range("B4").Value
    TopThreeFilms(3) = Sheet1.Range("B5").Value

    Worksheets.Add

    Range("A1") = TopThreeFilms(1)
    Range("A2") = TopThreeFilms(2)
    Range("A3") = TopThreeFilms(3)

    Erase TopThreeFilms

End Sub

Sub LoopOverArray()

    Dim TopTenFilms(1 To 10) As String
    Dim Counter As Long

    Sheet1.Activate

    For Counter = 1 To 10
            TopTenFilms(Counter) = Range("B2").Offset(Counter, 0).Value
    Next Counter

    Worksheets.Add

    For Counter = 10 To 1 Step -1
            ActiveCell.Value = TopTenFilms(Counter)
            ActiveCell.Offset(1, 0).Select

    Next Counter

    Erase TopTenFilms

End Sub

Sub LoopOverArrayUsingLBoundUBound()

    Dim TopTenFilms(1 To 13) As String
    Dim Counter As Long

    Sheet1.Activate

    For Counter = LBound(TopTenFilms) To UBound(TopTenFilms)
            TopTenFilms(Counter) = Range("B2").Offset(Counter, 0).Value
    Next Counter

    Worksheets.Add

    For Counter = UBound(TopTenFilms) To LBound(TopTenFilms) Step -1
            ActiveCell.Value = TopTenFilms(Counter)
            ActiveCell.Offset(1, 0).Select

    Next Counter

    Erase TopTenFilms

End Sub

Sub MultiDimensionArray()

    '数値や文字や日付があるので、variantでdimする
    Dim TopFilms(0 To 9, 0 To 4) As Variant
    Dim Counter As Long

    TopFilms(0, 0) = Range("A3").Value
    TopFilms(0, 1) = Range("B3").Value
    TopFilms(0, 2) = Range("C3").Value
    TopFilms(0, 3) = Range("D3").Value
    TopFilms(0, 4) = Range("E3").Value

    Erase TopFilms

End Sub

Sub MultiDimensionArray2()

    '数値や文字や日付があるので、variantでdimする
    Dim TopFilms(0 To 9, 0 To 4) As Variant
    Dim Dimension1 As Long, Dimension2 As Long

    For Dimension1 = 0 To 9
            For Dimension2 = 0 To 4
                    TopFilms(Dimension1, Dimension2) = Range("A3").Offset(Dimension1, Dimension2).Value
            Next Dimension2
    Next Dimension1

    Erase TopFilms

End Sub

Sub MultiDimensionArrayUsingLBoundUBound()

    '数値や文字や日付があるので、variantでdimする
    Dim TopFilms(0 To 9, 0 To 4) As Variant
    Dim Dimension1 As Long, Dimension2 As Long

    'LBound(arr,1)で、その二次元arrayの第1dimensionのLBoundを得る
    For Dimension1 = LBound(TopFilms, 1) To UBound(TopFilms, 1)

            'LBound(arr,2)で、その二次元arrayの第2dimensionのLBoundを得る
            For Dimension2 = LBound(TopFilms, 2) To UBound(TopFilms, 2)
                    TopFilms(Dimension1, Dimension2) = Range("A3").Offset(Dimension1, Dimension2).Value
            Next Dimension2

    Next Dimension1

    Worksheets.Add
    For Dimension1 = LBound(TopFilms, 1) To UBound(TopFilms, 1)

            'LBound(arr,2)で、その二次元arrayの第2dimensionのLBoundを得る
            For Dimension2 = LBound(TopFilms, 2) To UBound(TopFilms, 2)
                    ActiveCell.Offset(Dimension1, Dimension2).Value = TopFilms(Dimension1, Dimension2)
            Next Dimension2

    Next Dimension1

    Erase TopFilms

End Sub

Sub MultiDimensionDynamicArrayUsingLBoundUBound()
‘正直?にシートの行と列をスイープしてarrayに格納していく方法

    '()を忘れないように。忘れるとただのvariantになってしまう
    Dim TopFilms() As Variant
    Dim Dimension1 As Long, Dimension2 As Long

    Sheet1.Activate
    Dimension1 = Range("A3", Range("A2").End(xlDown)).Cells.Count - 1
    Dimension2 = Range("A2", Range("A2").End(xlToRight)).Cells.Count - 1

    ReDim TopFilms(0 To Dimension1, 0 To Dimension2)

    'LBound(arr,1)で、その二次元arrayの第1dimensionのLBoundを得る
    For Dimension1 = LBound(TopFilms, 1) To UBound(TopFilms, 1)

            'LBound(arr,2)で、その二次元arrayの第2dimensionのLBoundを得る
            For Dimension2 = LBound(TopFilms, 2) To UBound(TopFilms, 2)
                    TopFilms(Dimension1, Dimension2) = Range("A3").Offset(Dimension1, Dimension2).Value
            Next Dimension2

    Next Dimension1

    Worksheets.Add
    For Dimension1 = LBound(TopFilms, 1) To UBound(TopFilms, 1)

            'LBound(arr,2)で、その二次元arrayの第2dimensionのLBoundを得る
            For Dimension2 = LBound(TopFilms, 2) To UBound(TopFilms, 2)
                    ActiveCell.Offset(Dimension1, Dimension2).Value = TopFilms(Dimension1, Dimension2)
            Next Dimension2

    Next Dimension1

    Erase TopFilms

End Sub

Sub Quick_MultiDimensionDynamicArrayUsingLBoundUBound()
‘実は、rangeで簡単の2次元配列を格納できる
‘この方法では、インデックスは、option baseに関係なく1から始まる

    Dim TopFilms() As Variant

    Sheet1.Activate

    TopFilms = Range("A3", Range("A2").End(xlDown).End(xlToRight))

    Worksheets.Add 'Addすると自動的にA1セルがアクティブになる

    '"A1"から、UBOUNDの数(たてよこ)だけレンジを指定して、そこにTopFilmsArrayを流し込む
    Range(ActiveCell, ActiveCell.Offset(UBound(TopFilms, 1) - 1, UBound(TopFilms, 2) - 1)).Value = TopFilms

    Erase TopFilms

End Sub

Sub CalculateWithArray()

    Dim FilmLengths() As Variant
    Dim Answers() As Variant
    Dim Dimension1 As Long, Counter As Long

    Sheet1.Activate

    FilmLengths = Range("D3", Range("D2").End(xlDown))

    Dimension1 = UBound(FilmLengths, 1)

    ReDim Answers(1 To Dimension1, 1 To 2)

    For Counter = 1 To Dimension1
            Answers(Counter, 1) = Int(FilmLengths(Counter, 1) / 60)
            Answers(Counter, 2) = FilmLengths(Counter, 1) Mod 60
    Next Counter

    Range("F3", Range("F3").Offset(Dimension1 - 1, 1)).Value = Answers

    Erase FilmLengths
    Erase Answers

End Sub

Sub ResizeDynamicArray()

    Dim ActionFilms() As Variant
    Dim r As Range
    Dim ActionCounter As Long, LoopCounter As Long

    Sheet1.Activate

    For Each r In Range("A3", Range("A2").End(xlDown))
            'VBはcase sensitiveなので、念のためlcaseにしてから評価する
            If LCase(r.Offset(0, 4).Value) = "action" Then
                    ActionCounter = ActionCounter + 1

                    ReDim Preserve ActionFilms(1 To 5, 1 To ActionCounter)

                    For LoopCounter = 1 To 5
                            ActionFilms(LoopCounter, ActionCounter) = r.Offset(0, LoopCounter - 1).Value
                    Next LoopCounter

            End If
    Next r

    Worksheets.Add
    Range(ActiveCell, ActiveCell.Offset(4, UBound(ActionFilms, 2) - 1)).Value = ActionFilms

    Worksheets.Add
    Range(ActiveCell, ActiveCell.Offset(UBound(ActionFilms, 2) - 1, 4)).Value = Application.Transpose(ActionFilms)

End Sub

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です