VBA - naobe @ ウィキ

言語に戻る

バージョン

VB6.0

コメント

行先頭にシングルコーテーション

型

型	説明
Boolean	真偽値。True or False
String	文字列
Integer	整数（負数あり）。16ビット

制御構造

判定

 If 条件式 then
 ステートメント
 ElseIf 条件式 then
 ステートメント
 Else
 ステートメント
 End If

ループ

 Do [while 条件式]
 [exit Do] #ループから抜ける
 Loop

whileがない場合は無限ループ

クラス

不可能なこと

• 継承
• オーバーロード

作成方法

コーディング例

文字列

文字列の連結

 文字列1 & 文字列2

FORM

テキストボックス

【テキストボックスから文字列を取得する】

ボタン

【フォームを閉じる】

 Unload me

正規表現

使用方法は以下を参照

 '
 ' 正規表現マッチ判定
 '
 '@param patn 正規表現パターン
 '@param target 対象文字列
 '
 Private Function regmatch(patn As String, target As String) As Boolean
  Dim re
 	  Set re = CreateObject("VBScript.RegExp")
     
     re.Pattern = patn
     regmatch = re.Test(target)
 End Function

プログラミング例

DB2のselect結果を取得

【select結果】
'-'の数が、列の桁数になる。

 STORENUM   STARTDATE  NAME                 OPSTATE
 ---------- ---------- -------------------- -----------
 st001      2011-06-01 store1                         0
 st001      2011-06-02 store1                         1
 st001      2011-06-03 store1                         1
 st002      2011-06-02 store2                         0
 st002      2011-06-03 store2                         1
 st002      2011-06-04 store2                         1
 st003      2011-06-03 store3                         0
 st003      2011-06-04 store3                         1
 st003      2011-06-05 store3                         1

【シートプログラム】

 Option Explicit
 
 ' 出力開始セル
 Private startCell As Range
 
 ' データ開始セル
 Private dataCell As Range
 
 ' [[SQL]]ファイルパス
 Private sqlFilePath As String
 
 ' 支店EXCELディレクトリ（フルパス）
 Private branchDir As String
 
 ' 支店加盟店番号セル
 Private branchShopNumCell As String
 
 ' 支店加盟店番号セル
 Private branchShopNameCell As String
 
 ' 列リスト
 Private colList As Collection
 
 ' 列サイズ
 Private colSize As Integer
 
 ' ヘッダ
 Private header As String
 
 ' データ行到達フラグ
 Private isData As Boolean
 
 ' 終了フラグ
 Private isEnd As Boolean
 
 
 ' 加盟店マップ（キー：加盟店番号、値：加盟店名）
 Private shopMap As Dictionary
 
 Private Sub テスト_Click()
     Dim result As Boolean
     result = regmatch("\d{4}-\d{2}-\d{2}-\d{2}\.\d{2}\.\d{2}\.\d{6}", "2013-04-23-10.00.00.000002")
     
     MsgBox ("結果 : " & CStr(result))
     
 End Sub
 
 '
 ' 支店ディレクトリから支店excelファイルを読み込み、加盟店番号と加盟店名のマップを作成する
 ' SQLダンプファイルを読み込み保管する
 '
 Private Sub 実行_Click()
     Dim i As Integer
     
     ' 変数初期化
     isData = False
     isEnd = False
     Set startCell = Worksheets(SHEET_NAME).Range(START_CELL)
     Set dataCell = startCell.Offset(1, 0)
     Set shopMap = New Dictionary
     Set colList = New Collection
     
     ' 設定読み込み
     Call getConfig
     
     ' 支店EXCELファイルを読み込み、加盟店番号-加盟店名マップを作成
     Call createShopMap
     
     ' SQL読み込み
     Call readSQL
 
 End Sub
 
 '
 ' 設定値読み込み
 '
 Private Sub getConfig()
     sqlFilePath = Range(SQL_FILE_PATH).Value
     branchDir = Range(BRANCH_EXCELL_DIR).Value
     branchShopNumCell = Range(BRANCH_SHOP_NUM).Value
     branchShopNameCell = Range(BRANCH_SHOP_NAME).Value
 End Sub
 
 
 '
 ' 支店EXCELファイルを読み込み、加盟店マップ作成
 '
 Private Sub createShopMap()
     Dim f, fs, folder, fc
     Dim wb As Workbook
     Dim fileName, shopNum, shopName As String
 
     Set fs = CreateObject("Scripting.FileSystemObject")
     '支店EXCELファイルフォルダ
     Set folder = fs.GetFolder(branchDir)
     'フォルダ内のファイル
     Set fc = folder.Files
     For Each f In fc
         'ワークブックを開く
         fileName = branchDir & "\" & f.name
         'Debug.Print ("fileName : " & fileName)
         Set wb = Workbooks.Open(fileName:=fileName)
         
         '加盟店番号、加盟店名をマップに登録
         shopNum = wb.Sheets(1).Range(branchShopNumCell).Value
         shopName = wb.Sheets(1).Range(branchShopNameCell).Value
         'Debug.Print "shopNum : " & shopNum & " shopName : " & shopName
         shopMap.Add shopNum, shopName
         
         'ワークブックを閉じる
         wb.Close
     Next
 
     ' 加盟店マップダンプ
     Call dumpMap("加盟店番号", "加盟店名", shopMap)
     Debug.Print ""
 End Sub
 
 '
 ' 加盟店マップダンプ
 '
 '@param keyName キー名
 '@param valueName 値名
 '@param map ダンプするマップ
 '
 Private Sub dumpMap(keyName As String, valueName As String, map As Dictionary)
     Dim keyAry
     Dim i As Integer
     Dim val As String
     
     keyAry = map.keys
     For i = 0 To map.Count - 1
         val = map.Item(keyAry(i))
         Debug.Print keyName & " : " & keyAry(i) & ", " & valueName & " : " & val
     Next
 End Sub
 '
 ' SQL select結果をシートにロードする
 '
 Public Sub readSQL()
     Dim fileNo As Integer
     Dim buf As String
     Dim ret As Integer
     
     fileNo = FreeFile
     Open sqlFilePath For Input As #fileNo
     Do Until EOF(fileNo)
         Line Input #fileNo, buf
         Call loadToSheet(buf)
     Loop
     Close #fileNo
 End Sub
 
 '
 ' 行をシートに登録する
 '
 '@paarm line 行
 '@param sheetName シート名
 '
 Public Sub loadToSheet(line As String)
     ' 行マップ（キー：カラム名、値：カラム値）
     Dim lineMap As Dictionary
     
     Dim top As String
     If isData = False Then
         ' ヘッダ行処理
         ' 空行は終了
         If Len(line) = 0 Then
             Exit Sub
         End If
         top = Mid(line, 1, 1)
         '---行まで進む
         If top = "-" Then
             isData = True
             ' 列サイズ取得
             Call extractColSize(line)
             ' ヘッダ行から列名取得
             Call getColumnName
         Else
             ' ---行まで、ヘッダ行保管
             header = line
         End If
     Else
         ' データ行処理
         ' 空行になったら終了
         If Len(line) = 0 Then
             isEnd = True
             Exit Sub
         End If
         ' 終了なら何もしない
         If isEnd = True Then
             Exit Sub
         End If
         ' データ行
         'Call writeData(line)
         Set lineMap = getLineMap(line)
         ' 行マップダンプ
         Call dumpMap("名前", "値", lineMap)
         Debug.Print ""
     End If
 End Sub
 
 '
 ' 列サイズ抽出
 '
 '@param line ---の行
 '
 Sub extractColSize(line As String)
     Dim pos, prevPos, start As Integer
     
     start = 0
     prevPos = 1
     pos = -1
     ' 行からブランクを探す
     Do While True
         Dim col As ColumnClass
         Set col = New ColumnClass
         pos = InStr(prevPos, line, " ")
         If pos = 0 Then
             '最後の列の列サイズを保管
             col.size = Len(line) - prevPos + 1
             colList.Add col
             Exit Do
         Else
             ' 列サイズを保管
             col.size = pos - prevPos
             colList.Add col
             prevPos = pos + 1
         End If
     Loop
 End Sub
 
 '
 ' ヘッダから列名を取得する
 '
 Private Sub getColumnName()
     Dim i, pos As Integer
     Dim col As ColumnClass
     
     pos = 1
     For i = 1 To colList.Count
         'colAry(i).name = Trim(Mid(header, pos, colAry(i).size))
         Set col = colList.Item(i)
         col.name = Trim(Mid(header, pos, col.size))
         pos = pos + col.size + 1
     Next
 End Sub
 '
 ' データ行をシートに書き込む
 '
 '@param line データ行
 '
 Private Function getLineMap(line As String) As Dictionary
     Dim pos, i As Integer
     Dim lineMap As Dictionary
     Dim col As ColumnClass
     
     Set lineMap = New Dictionary
         
     pos = 1     'カラム位置
     'データ出力
     For i = 1 To colList.Count
         Set col = colList.Item(i)
         ' データ行から値を取得してマップに登録
         lineMap.Add col.name, Trim(Mid(line, pos, col.size))
         ' 次のカラム位置を計算
         pos = pos + col.size + 1
     Next
     Set getLineMap = lineMap
 End Function
 
 '
 ' データ行をシートに書き込む
 '
 '@param line データ行
 '
 Private Sub writeData(line As String)
     Dim pos, i As Integer
     '開始セル
     Dim tmpCell As Range
     Set tmpCell = dataCell
         
     pos = 1
     'データ出力
     For i = 0 To colSize
         ' 表示形式を文字列に設定
         tmpCell.NumberFormatLocal = "@"
         'ファイルの行から値を取得してセルに設定
         tmpCell.Value = Trim(Mid(line, pos, colAry(i).size))
         ' 1列右へ移動
         Set tmpCell = tmpCell.Offset(0, 1)
         pos = pos + colAry(i).size + 1
     Next
     ' dataCellを１行下へ移動
     Set dataCell = dataCell.Offset(1, 0)
 End Sub
 
 
 '
 ' 正規表現マッチ判定
 '
 '@param patn 正規表現パターン
 '@param target 対象文字列
 '
 Private Function regmatch(patn As String, target As String) As Boolean
     Dim re
     Set re = CreateObject("VBScript.RegExp")
     
     re.Pattern = patn
     regmatch = re.Test(target)
 End Function

【標準モジュール】

 Option Explicit
 
 '出力シート名
 Public Const SHEET_NAME As String = "Sheet2"
 
 ' 最大列数
 Public Const MAXCOL As Integer = 50
 
 ' 出力開始設定セル
 Public Const START_CELL As String = "B2"
 
 ' SQLダンプファイル（フルパス）設定セル
 Public Const SQL_FILE_PATH As String = "C4"
 
 ' 支店EXCELディレクトリ（フルパス）設定セル
 Public Const BRANCH_EXCELL_DIR As String = "C5"
 
 ' 支店加盟店番号セル設定セル
 Public Const BRANCH_SHOP_NUM As String = "C7"
 
 ' 支店加盟店番号セル設定セル
 Public Const BRANCH_SHOP_NAME As String = "C8"

【クラスモジュール ColumnClass】

 Option Explicit
 
 Public size As Integer 'サイズ
 Public name As String  '名前

ファイル書き込み

 Private Sub FileWrite_Click()
     ' 変数宣言
     Dim fileName As String                      ' 書き込みファイル名
     Dim rows As Variant
     Dim row As Integer
     Dim fileNumber As Integer
     Dim fileExist As String
     
     fileNumber = FreeFile
     
     ' ファイル名をセルから読み込み
     fileName = Range("C13").Value
     
     ' 書き込む文字列を取得
     rows = Range("C18", "C21")
     
     ' ファイルがあれば削除
     fileExist = Dir(fileName)
     If fileExist <> "" Then
         Kill fileName
     End If
     
     ' ファイル書き込み
     Open fileName For Append As #fileNumber
     For row = 1 To 4
         Print #fileNumber, rows(row, 1)
     Next
     Close #fileNumber
 
     MsgBox "ファイル:" & fileName & "に文章を書き込みました"
 
 End Sub

指定したセルから値を取得してSQL作成

【標準モジュール】

 Option Explicit
 
 ' 検索開始行
  Const START_ROW = 4
 
 ' 検索終了行
  Const END_ROW = 10
 
 ' NAMEID列
 Const NAMEID_COL = 2
 
 
 Sub SQL作成_Click()
     ' NAMEID
     Dim nameIdCell As Range
     ' 行
     Dim row As Integer
     ' ID
     Dim id As Integer
     '　文字列ID
     Dim sid As String
     
     ' 初期値を設定
     row = START_ROW
     id = 1
     
     ' 最終行まで、SQL文作成
     Do While row <= END_ROW
         Set nameIdCell = Cells(row, NAMEID_COL)
         ' id を３桁で０埋め
         sid = PadLeft(CStr(id), 3, "0")
         ' SQL文出力
         Debug.Print "insert into INOUTDETAIL values('D20120304" & sid & "', 'その他', '" & nameIdCell.Value & "');"
         row = row + 1
         id = id + 1
     Loop
     Debug.Print "commit work;"
 
 End Sub
 
 ' -------------------------------------------------------------------------------
 '       指定の文字数になるまで先頭を文字で埋めます。
 '
 ' @Param    stTarget    処理対象となる文字列。
 ' @Param    iLength     文字の長さ。
 ' @Param    [chOne]     埋める文字。(省略時は半角スペース)
 ' @Return               先頭を指定の文字で iLength の長さまで埋められた文字列。
 ' -------------------------------------------------------------------------------
 Public Function PadLeft(ByVal stTarget As String, ByVal iLength As Integer, Optional ByVal chOne A  s String = " ") As String
     Do While (Len(stTarget) < iLength)
         stTarget = chOne & stTarget
     Loop
 
     PadLeft = Right$(stTarget, iLength)
 End Function

英単語帳に単語登録機能を追加する

【フォームモジュール】

 Option Explicit
 
 ' 検索開始セル
 Const START_CELL = "C5"
 
 '左端列
 Const START_COLUMN = "B"
 
 '右端列
 Const END_COLUMN = "F"
 
 '品詞マップ
 Dim hinshiMap As Object
 
 '
 ' フォーム初期処理
 '
 Private Sub UserForm_Initialize()
     '品詞初期化
     Dim hinshiNameAry() As String
     Dim hinshiValAry() As String
     hinshiNameAry = Split(MEISI & "," & MEISI_DOUSI & "," & DOUSI & "," & KEIYOUSI & "," & HUKUSI   & "," & ZENTISI, ",")
     hinshiValAry = Split(MEISI_VAL & ":" & MEISI_DOUSI_VAL & ":" & DOUSI_VAL & ":" & KEIYOUSI_VAL   & ":" & HUKUSI_VAL & _
                         ":" & ZENTISI_VAL, ":")
     'コンボボックス初期化
     With hinshi
         Dim i As Integer
         For i = 0 To HINSHI_CNT - 1
             .AddItem hinshiNameAry(i)
         Next i
         .Text = .List(0)
     End With
 
     '品詞マップに登録
     Set hinshiMap = CreateObject("Scripting.Dictionary")
     With hinshiMap
         For i = 0 To HINSHI_CNT - 1
             .Add hinshiNameAry(i), hinshiValAry(i)
         Next i
     End With
 End Sub
 
 '
 ' 追加ボタン押下処理
 '
 Private Sub AddButton_Click()
     Dim 単語 As String
     Dim 品詞 As String
     Dim 訳 As String
     
     単語 = word.Text
     品詞 = hinshiMap.Item(hinshi.Text)
     訳 = translation.Text
         
     Debug.Print "追加ボタンがクリックされました。 単語：" & 単語 & " 品詞:" & 品詞 & " 訳：" + 訳
     
     'シートへ登録
     '  追加する位置のセルを求める
     Dim targetCell As Range
     Dim tmpCell As Range
     Set targetCell = findTargetCell(単語)
     If targetCell Is Nothing Then
         MsgBox prompt:="既に登録されています", Buttons:=vbCritical
         Exit Sub
     End If
     
     Debug.Print "追加するセル位置：" & targetCell.Address
     
     '  行を追加
     targetCell.EntireRow.Insert
     
     ' 先頭に追加か否かで、Noをコピーする行を変える
     If targetCell.Address = Range(START_CELL).Offset(1, 0).Address Then
         '先頭に追加
         '  Noをコピー
         Set tmpCell = targetCell.Offset(0, -1)
         tmpCell.Copy Destination:=tmpCell.Offset(-1, 0)
         '  形式をコピー
         Dim rangeStr As String
         rangeStr = getRangeStr(tmpCell.row)
         Range(rangeStr).Copy
         rangeStr = getRangeStr(tmpCell.row - 1)
         Range(rangeStr).PasteSpecial Paste:=xlPasteFormats
     Else
         '  2行上(No)をコピー
         Set tmpCell = targetCell.Offset(-2, -1)
         tmpCell.Copy Destination:=tmpCell.Offset(1, 0)
     End If
     
     ' 空行に移動
     Set targetCell = targetCell.Offset(-1, 0)
     ' 入力値をセット
     targetCell.Value = 単語
     targetCell.Offset(0, 1).Value = 品詞
     targetCell.Offset(0, 2).Value = 訳
     
     ' 日付をセット
     targetCell.Offset(0, 3).NumberFormatLocal = "yyyy/m/d"
     targetCell.Offset(0, 3).Value = Date
 End Sub
 
 '
 '範囲文字を取得する
 '
 '引数 row 行
 '戻り値 範囲文字列(ex. "A1:C3")
 '
 '
 Private Function getRangeStr(row As Long)
     getRangeStr = START_COLUMN & CStr(row) & ":" & END_COLUMN & CStr(row)
 End Function
 
 '
 ' キャンセルボタン押下処理
 '
 Private Sub CancelButton_Click()
     ' 閉じる
     Unload Me
 End Sub
 
 '
 ' 追加するセル位置を求める
 '
 ' 引数 wordVal 単語
 ' 戻り値 追加するセル。同じ単語があればNothing
 '
 Private Function findTargetCell(wordVal As String)
     ' 単語比較結果
     Dim compResult As Integer
     ' 比較対象セル
     Dim targetCell As Range
     
     Set targetCell = Range(START_CELL)
     ' 検索
     Dim isSameWord As Boolean
     isSameWord = False
     Do
         '最終行チェック
         If targetCell.Value = Empty Then
            Exit Do
         End If
         compResult = StrComp(targetCell.Value, wordVal, vbTextCompare)
         'セルの文字列が追加単語より後なら終了
         If compResult = 1 Then
             ' 同じ単語か確認
             If targetCell.Offset(-1, 0).Value = wordVal Then
                 Set targetCell = Nothing
             End If
             Exit Do
         End If
         ' 1行下に移動
         Set targetCell = targetCell.Offset(1, 0)
     Loop
 
     ' 戻り値
     Set findTargetCell = targetCell
 End Function
 
 
 '
 ' セル形式を変換する
 '
 ' 引数 rangeName $A$1形式のセル名
 ' 戻り値 A1形式のセル名
 '
 Private Function cnvRangeForm(rangeName As String)
     ' $を削除
     cnvRangeForm = Replace(rangeName, "$", "")
 End Function
 

【シートモジュール】

 Option Explicit
 
 Private Sub CommandButton1_Click()
     UserForm1.Show vbModal
 End Sub

【標準モジュール】

 Option Explicit
 
 '品詞名
 Public Const MEISI = "名詞"
 Public Const DOUSI = "動詞"
 Public Const MEISI_DOUSI = "名詞+動詞"
 Public Const KEIYOUSI = "形容詞"
 Public Const HUKUSI = "副詞"
 Public Const ZENTISI = "前置詞"
 
 '品詞
 Public Const MEISI_VAL = "n"
 Public Const DOUSI_VAL = "v"
 Public Const MEISI_DOUSI_VAL = "n,v"
 Public Const KEIYOUSI_VAL = "a"
 Public Const HUKUSI_VAL = "adv"
 Public Const ZENTISI_VAL = "prep"
 
 '品詞の数
 Public Const HINSHI_CNT = 6