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

Outlookの練習-2

Option Explicit

Sub SendComplexEmail_HTML()
‘Microsoft Outlook 16.0 libraryを early bindingする

    'Outlookは、このあたりのdimやsetはもう丸覚えしかない。テクニカルな説明は存在するが、何回聞いても理解できない。ExcelとOutlookはそもそも構造が違うので。
    Dim olApp As Outlook.Application
    Dim olEmail As Outlook.MailItem
    Set olApp = New Outlook.Application
    Set olEmail = olApp.CreateItem(olMailItem)

    With olEmail
            .BodyFormat = olFormatHTML
            .Display

            .HTMLBody = "Dear Someone<br><br>" & GetMovieDataHTML & .HTMLBody

            .To = "akijsaito@mac.com"
            .Subject = "Movie Report"
    End With

End Sub

Function GetMovieDataHTML() As String
‘これは面白い。どこかで役に立つ

    Dim FilmColumn As Range, FilmRow As Range, r As Range, c As Range
    Dim str As String

    Sheet1.Activate
    Set FilmRow = Range("A2", Range("A1").End(xlDown))

    str = "<table>"
    For Each r In FilmRow   '全部の行をスイープする
            str = str & "<tr>"
            Set FilmColumn = Range(r, r.End(xlToRight))
                    For Each c In FilmColumn        '全部のカラムをスイープする
                            str = str & "<td>" & c.Value & "</td>"

‘ ‘最後のカラムのあとにvbtabを入れないようにするため
‘ If c.Column < r.End(xlToRight).Column Then
‘ str = str & vbTab
‘ End If

                    Next c

                    str = str & "</tr>"

‘ ‘最後の行のあとにvbnewlineを入れないようにするため
‘ If r.Row < Range(“A1”).End(xlDown).Row Then
‘ str = str & vbNewLine
‘ End If

    Next r

    str = str & "</table>"

    GetMovieDataHTML = str

End Function

‘ ‘ ‘ ‘ ‘ ‘ ‘ ‘ ‘ ‘

column1 column2
Row 2 Row 2

GetOpenFileNameの練習-1

Option Explicit

Sub Consolidate()

Dim FileNameList As Variant
Dim i As Long
Dim FileName As String

Dim SourceFileName As String

FileNameList = Application.GetOpenFilename(“Microsoft Excelブック, *.xlsx”, MultiSelect:=True)

If IsArray(FileNameList) Then
    For i = 1 To UBound(FileNameList)

    Debug.Print FileNameList(i)

    FileName = FileNameList(i)

    Debug.Print Dir(FileName)

   Workbooks.Open SourceFileName
    Next i

Else
    MsgBox "Cancelled"
End If

End Sub

ADOの練習-1

Option Explicit

‘Connection StringはCONSTで書いておくと便利
Const ConStrAccess As String = “Provider=Microsoft.ACE.OLEDB.12.0; ” & _
“Data Source=C:\Users\Akishige Saito\Documents\VeryLargeDatabase.accdb;” & _
“Persist Security Info=False;”

Const ConStrSQL As String = “Provider=SQLNCLI11;” & _
“Server=SURFACELAPTOPBU;” & _
“Database=myDataBase;” & _
“Trusted_Connection=yes;”

Sub CopyDataFromAccessDatabase()
Dim MoviesConn As ADODB.Connection
Dim MoviesData As ADODB.Recordset
‘ADODB.fieldは、テーブルの列名を得る方法
Dim MoviesField As ADODB.Field

    Set MoviesConn = New ADODB.Connection
    Set MoviesData = New ADODB.Recordset

    'connectionstrings.comを参考にしよう
    MoviesConn.ConnectionString = ConStrAccess
    MoviesConn.Open

    On Error GoTo CloseConnection

    With MoviesData
            .ActiveConnection = MoviesConn
            '.sourceにSQLを書く
            .Source = "SELECT tblMovie.director_name FROM tblMovie WHERE (((tblMovie.director_name) Like 'a%'));"
            .LockType = adLockReadOnly
            .CursorType = adOpenForwardOnly
            .Open
    End With

    On Error GoTo CloseRecordset

    Worksheets.Add

    'ADODB.fieldを、シートの1行目にセットするループです
    For Each MoviesField In MoviesData.Fields
            ActiveCell.Value = MoviesField.Name
            ActiveCell.Offset(0, 1).Select
    Next MoviesField

    Range("A1").Select

    'CopyFromRecordsetで、簡単に全レコードを持ってこれる
    Range("A2").CopyFromRecordset MoviesData
    'シートをオートフィットさせる
    Range("A2").CurrentRegion.EntireColumn.AutoFit

    On Error GoTo 0

CloseRecordset:
MoviesData.Close

CloseConnection:
MoviesConn.Close

End Sub

Sub CopyDataFromSQLServer_Database()
Dim MoviesConn As ADODB.Connection
Set MoviesConn = New ADODB.Connection

    'connectionstrings.comを参考にしよう
    MoviesConn.ConnectionString = ConStrSQL

    MoviesConn.Open

    MoviesConn.Close

End Sub