ak VBA

　 サ　ン　プ　ル

VBA中断　Ctrl+Breakキーを押して"終了(E)"

拡張子に関連しているソフトを起動させる

Option Explicit
Private Declare Function ShellExecute Lib "SHELL32.DLL" Alias
"ShellExecuteA" ( _
    ByVal hWnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As EnumShowCommand _
) As Long
' ShowCommand 列挙体
Private Enum EnumShowCommand
    OpenWindow = 1
    IconWindow = 2
    FullScreen = 3
    NoActivate = 4
End Enum
Sub test()
'Call Shell("Excel D:\down\A.xls", vbNormalFocus)
'Call Shell("Notepad D:\down\A.txt", vbNormalFocus)
Call ShellExecute(0, "Open", "D:\down\A.txt", ByVal 0&, ByVal 0&,
EnumShowCommand.OpenWindow)
End Sub

シート 1でセル範囲 A1:C3 を選択しセルB2をアクティブセルにする

Worksheets("Sheet1").Activate
Range("A1:C3").Select
Range("B2").Activate

ステータスバーを表示する

oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "しばらくお待ちください..."
Workbooks.Open filename:="LARGE.XLS"
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

エクセル起動時にマクロを動かす　（Ｓｈｉｆｔ＋開くはマクロが動かない）

Sub AUTO_OPEN()
　MsgBox ActiveWorkbook.Name '作業中のブックの名前を表示します
End Sub

マクロの実行パスを返す　カレントパス

ThisWorkbook.Path

[開く]又は保存ダイアログボックスを表示する

Application.Dialogs(xlDialogSaveAs).Show
Application.Dialogs(xlDialogOpen).Show

マクロの実行中に特定の警告やメッセージを制御する

Application.DisplayAlerts = False

マクロの速度を向上させるため、画面を更新しない

Application.ScreenUpdating = False

ウィンドウの状態を設定する

Application.WindowState = xlMaximized

アクティブウィンドウ内にあるブックを返す

ActiveWorkbook.Name

アクティブセル領域を範囲選択する

Worksheets("Sheet1").Range("A1").CurrentRegion.Select

アクティブセル領域の行数を取得する（最終行）

MsgBox Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count

Book1.XLSブックを開く

Workbooks.Open filename:="Book1.XLS"

Book1.XLSブックをアクティブにする

Workbooks("BOOK1．XLS").Activate

アクティブウィンドウのブックを保存せずに閉じる

ActiveWindow.Close SaveChanges:=False
Windows("xxx.xls").Close savechanges:=False
Workbooks("xxx").Application.Visible = True
Workbooks("xxx").Activate

作業中のブックを除く、他に開いているすべてのブックを保存して閉じる

For Each w In Workbooks
If w.Name <> ThisWorkbook.Name Then
w.Close savechanges:=True
End If
Next w

マウスカーソルの形状を砂時計に変更する

Application.Cursor = xlWait

セルC5のフォントサイズを 14 ポイントに設定する

Worksheets("Sheet1").Cells(5, 3).Font.Size = 14

セル1をクリアする

Worksheets("Sheet1").Cells(1).ClearContents

シートをクリアする

Worksheets("SHEET1").Activate
Cells.Select
Selection.ClearContents

セルの行、列を求める

Worksheets("Sheet1").Activate
MsgBox Selection.row
MsgBox Selection.column

印刷する

Sheets("Sheet1").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1

シートの削除とセルの初期化

Sub Test()
Dim objTargetBook As Workbook
Dim SheetCount As Long
Dim i As Long
Application.DisplayAlerts = False
With ThisWorkbook
'Sheet1以外は全て削除する
SheetCount = .Worksheets.Count
For i = SheetCount To 1 Step -1
If StrComp(.Worksheets(i).Name, "Sheet1") <> 0 Then
.Worksheets(i).Delete
End If
Next i
'セルを初期化する
With .Worksheets("Sheet1")
.Cells(1, 1).ClearContents
.Range(.Cells(2, 1), .Cells(5, 1)).ClearContents
End With
End With
Application.DisplayAlerts = True
End Sub

文字列の操作　漢字含む

Sub MidSample()
Dim MyString
MyString = "ＡbＣdＥfＧ"
' "Ａ"、"Ｃ"、"Ｅ" および "Ｇ" は全角文字で、"b"、"d"、
' および "f" は半角文字です。

MyNewString = mid(MyString, 3, 4)
MsgBox MyNewString
' "ＣdＥf" が返されます。

MyNewString = MidB(MyString, 3, 4)
MsgBox MyNewString
' Windows の場合は "bＣ" が、Macintosh の場合は "bＣd" が返されます。

MyNewString = MidMbcs(MyString, 3, 4)
MsgBox MyNewString
' Windows の場合は "bＣd" が返されます。Macintosh の場合は Unicode が
' サポートされていないため、エラーが返されます。
End Sub

Function MidMbcs(ByVal str As String, start, length)
MidMbcs = StrConv(MidB(StrConv(str, vbFromUnicode), start, length), vbUnicode)
End Function

文字列の長さ　漢字含む

Sub Sample1()
'例1:文字列の ANSI 形式でのバイト長を求めます
a = "ABあい"
MsgBox LenB(a) ' 32bit 版では 8 を返す
b = StrConv(a, vbFromUnicode)
MsgBox LenB(b) ' 32bit 版でも 6 を返す
'例2:文字列から文字を検索し、先頭からの ANSI 形式でのバイト位置を求めます
a = "ABあい"
MsgBox InStrB(a, "い") ' 32bit 版では 7 を返します
b = Left(a, InStr(a, "い"))
MsgBox LenB(StrConv(b, vbFromUnicode)) ' 32bit 版でも 6 を返します
End Sub

Function lenw(str As String) As Long
lenw = LenB(StrConv(str, vbFromUnicode))
End Function

キー検索

Sub setCd()
Dim i As Long
Dim j As Long
Dim lonTry As Long
Dim strDat As String
    For i = 3 To 435
        lonTry = 0
        strDat = Cells(i, 5)
A:
        For j = 3 To 61
            If strDat = Cells(j, 8) Then
                Cells(i, 3) = Cells(j, 7)
                Exit For
            End If
        Next j
        If Cells(i, 3) = "" Then
            lonTry = lonTry + 1
            If lonTry = 4 Then
                'MsgBox "NG i=" & i
            Else
                strDat = Left(strDat, 4 - lonTry) '& String(lonTry, "*")
                GoTo A
            End If
        End If
    Next i
    MsgBox "終劇"
End Sub

フルパスからファイル名を取り出す

Function getFileName(strFile As String) As String
Dim j As Long
    For j = Len(strFile) To 1 Step -1
        If Mid(strFile, j, 1) = "\" Then Exit For
    Next j
    getFileName = Right(strFile, Len(strFile) - j)
End Function

時間編集

Function HHMM(X As String) As String
Dim HH As String, MM As String
    If X = Null Or X = "" Or Val(X) = 0 Then
        HHMM = ""
    Else
        HH = Left(X, 2)
        MM = Right(X, 2)
        HHMM = HH & ":" & MM
    End If
End Function

小数点切捨

Sub sample()
Dim i As Long
For i = 1 To 16
    Debug.Print CROUNDDOWN(i / 12, 1)
Next i
End Sub

Function CROUNDDOWN(dblfwk As Double, intwk As Integer) As Double
Dim dblfwk1 As Double
Dim lngfwk1 As Long
    If intwk = 0 Then
        CROUNDDOWN = 0
    Else
        intwk = intwk - 1
        dblfwk1 = dblfwk * (10 ^ Abs(intwk))
        lngfwk1 = Int(dblfwk1)
        CROUNDDOWN = lngfwk1 / (10 ^ Abs(intwk))
    End If
End Function

日付編集

Function YYMMDD(X As String) As String
Dim YY As String, MM As String, DD As String
    If X = Null Or X = "" Or Val(X) = 0 Then
        YYMMDD = ""
    Else
        YY = Left(X, 4)
        MM = Mid(X, 5, 2)
        DD = Right(X, 2)
        YYMMDD = YY & "/" & MM & "/" & DD
    End If
End Function

シングルクォーテーション対応（SQL Insert）

Private Function itemEdit(strItem) As String
    If strItem = "" Then
        itemEdit = "Null"
    Else
        itemEdit = "'" & Replace(strItem, "'", "''") & "'"
    End If
End Function

Function Nullset(varWk As Variant, strFlg As String) As String
    If IsNull(varWk) = True Or varWk = "" Then
        Nullset = "Null"
    Else
        If strFlg = "C" Then
            If InStr(1, varWk, "'") = 0 Then
                Nullset = "'" & varWk & "'"
            Else
                Nullset = """" & varWk & """"
            End If
        ElseIf strFlg = "D" Then
            Nullset = "#" & varWk & "#"
        ElseIf strFlg = "9" Then
            Nullset = varWk
        End If
    End If
End Function

システムフォルダーを求める

Declare Function GetWindowsDirectory Lib "kernel32" Alias _
"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Sub Sample1()()
Dim Gwdvar As String
Dim Gwdvar_Length As Long
'結果を保存する領域をメモリ上に確保します
Gwdvar = Space(255)
' GetWindowsDirectory 関数は戻り値として Windows ディレクトリの文字列の長さ
' を返し、パス名を示す文字列を変数 "Gwdvar" に保存します
'Gwdvar_Length = GetWindowsDirectory(lpBuffer:=Gwdvar, nSize:=255)
Gwdvar_Length = GetWindowsDirectory(lpBuffer:=Gwdvar, nSize:=255)
MsgBox Left(Gwdvar, Gwdvar_Length) '余分な文字を削除します.
End Sub

印刷ページ総数を求める

     Sub PrintPage()
         Dim H_Break As Integer
         Dim V_Break As Integer
         Dim P_Page As Integer
         Dim A_Cell As String
         A_Cell = Sheet1.UsedRange.Address       '最後のセルのアドレスを取得
         If A_Cell = "$A$1" Then
             If IsEmpty(Sheet1.Range(A_Cell).Value) Then
                 MsgBox "印刷するデータはありません。"
                 Exit Sub
             End If
         End If
         H_Break = Sheet1.HPageBreaks.Count    '横の改ページ数取得
         V_Break = Sheet1.VPageBreaks.Count    '縦の改ページ数取得
         If V_Break = 0 Then
             P_Page = H_Break + 1
         Else
           H_Break = H_Break + 1
           V_Break = V_Break + 1
           P_Page = H_Break * V_Break
         End If
         MsgBox "印刷ページ総数： " & P_Page & " Page"
     End Sub

フォルダー名を求める

Sub Sample1()
Dim DirName As String, FileName As String
Dim CNT As Integer
DirName = "c:\"
CNT = 1
FileName = Dir(DirName, 16)
Do While Len(FileName) <> 0
On Error Resume Next
If GetAttr(DirName & FileName) = 16 Then
If Err <> 53 Then
Sheets("sheet1").Cells(CNT, 3).Value = FileName
CNT = CNT + 1
End If
End If
On Error GoTo 0
FileName = Dir()
'Debug.Print Spc(5); FileName
Loop
End Sub

ユーザー名を求める

Option Explicit
'ユーザー情報
Public Declare Function GetUserNameA Lib "advapi32" (ByVal buf As String, size As Long) As Long
Public Declare Function GetUserNameW Lib "advapi32" (ByVal buf As String, size As Long) As Long

'OS情報
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32_NT = 2
Public Declare Function GetVersionExA Lib "kernel32" (verinfo As OSVERSIONINFO) As Long
Public Declare Function GetVersionExW Lib "kernel32" (verinfo As OSVERSIONINFO) As Long

Sub test()
Dim sp As String
Dim us As Integer

sp = Space(128)
us = GetUserName(sp, Len(sp))
If us <> 0 Then
sp = LCase(Trim(Left(sp, InStr(sp, Chr(0)) - 1)))
Else
sp = "エラー"
End If
MsgBox sp
End Sub

Public Function GetUserName(buf As String, size As Long) As Long
On Local Error Resume Next
If GetOS() = VER_PLATFORM_WIN32_NT Then
GetUserName = GetUserNameW(buf, size)
Else
GetUserName = GetUserNameA(buf, size)
End If
If Err <> 0 Then
buf = ""
GetUserName = 0
End If
On Local Error GoTo 0
End Function

Public Function GetOS() As Long
Static osinfo As OSVERSIONINFO
Static init As Boolean
Dim rcd As Long
If init = False Then
osinfo.dwOSVersionInfoSize = LenB(osinfo)
On Local Error Resume Next
If GetVersionExA(osinfo) = False Then osinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS
rcd = Err
On Local Error GoTo 0
If rcd <> 0 Then
If GetVersionExW(osinfo) = False Then osinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS
End If
init = True
End If
GetOS = osinfo.dwPlatformId
End Function

英語日付

Function edate(dat1 As Date) As String
    Dim stry As String
    Dim strm As String
    Dim strd As String
    edate = ""
    stry = ""
    strm = ""
    strd = ""
    Select Case (Day(dat1))
      Case 1, 21, 31
        strd = Day(dat1) & "ST "
      Case 2, 22
        strd = Day(dat1) & "ND "
      Case 3, 23
        strd = Day(dat1) & "RD "
      Case Else
        strd = Day(dat1) & "TH "
    End Select
    Select Case (Month(dat1))
      Case (1)
        strm = "JAN.,"
      Case (2)
        strm = "FEB.,"
      Case (3)
        strm = "MAR.,"
      Case (4)
        strm = "APR.,"
      Case (5)
        strm = "MAY.,"
      Case (6)
        strm = "JUN.,"
      Case (7)
        strm = "JUL.,"
      Case (8)
        strm = "AUG.,"
      Case (9)
        strm = "SEP.,"
      Case (10)
        strm = "OCT.,"
      Case (11)
        strm = "NOV.,"
      Case (12)
        strm = "DEC.,"
    End Select
    stry = Year(dat1)
    edate = strd & strm & stry
End Function

条件

Sub test()
Dim a As Long
Dim b As Long
Dim c As Boolean
Dim i As Long

For i = 2 To 5
a = Worksheets("Sheet1").Cells(i, 2).Value
b = Worksheets("Sheet1").Cells(i, 3).Value
If a <> 0 Or b <> 0 Then
c = True
Else
c = False
End If
Worksheets("Sheet1").Cells(i, 4).Value = ""
Worksheets("Sheet1").Cells(i, 4).Value = c
Next i

For i = 8 To 11
a = Worksheets("Sheet1").Cells(i, 2).Value
b = Worksheets("Sheet1").Cells(i, 3).Value
If a = 0 And b = 0 Then
c = True
Else
c = False
End If
Worksheets("Sheet1").Cells(i, 4).Value = ""
Worksheets("Sheet1").Cells(i, 4).Value = c
Next i
End Sub

A	B	C
0	0	FALSE
100	0	TRUE
0	100	TRUE
100	100	TRUE

A	B	C
0	0	TRUE
100	0	FALSE
0	100	FALSE
100	100	FALSE

文字置き換え

MsgBox Replace(str, "*", " ", 1)　ちょっと違う

Call ReplaceString(1, wkteki, Chr(0), " ")

Public Function ReplaceString(ByVal lngStart As Long, ByRef strString1 As String, _
ByVal strString2 As String, ByVal strSrc As String, _
Optional ByVal enumCompare As VbCompareMethod = vbBinaryCompare) As Long
Dim strBuffer1 As String
Dim strBuffer2 As String
Dim lngCnt As Long
Dim lngPos As Long

'' 開始位置の有効チェック
If lngStart <= 0 Then Exit Function
'' 変数の初期化
strBuffer2 = Right$(strString1, Len(strString1) - (lngStart - 1))
strBuffer1 = Left$(strString1, lngStart - 1)
lngCnt = 0
Do
'' 文字列を検索する
lngPos = InStr(1, strBuffer2, strString2, enumCompare)
If lngPos = 0 Then
strBuffer1 = strBuffer1 & strBuffer2
Exit Do
End If
lngCnt = lngCnt + 1
strBuffer1 = strBuffer1 & Left$(strBuffer2, lngPos - 1) & strSrc
strBuffer2 = Right$(strBuffer2, Len(strBuffer2) - ((lngPos + Len(strString2)) - 1))
Loop
GPrcReplaceString = lngCnt
strString1 = strBuffer1

End Function

ACC2000式で Int 関数を使用する場合、予期しない結果

'http://support.microsoft.com/kb/242933/ja
Sub test()
    Dim dbl As Double
    MsgBox Int(5930)
    MsgBox Int(59.3 * 100)
    dbl = 59.3 * 100
    MsgBox Int(dbl)
    MsgBox Int(CDec(59.3) * 100)
End Sub

エラーを起こす

Dim Msg
' エラーが発生したら、エラーメッセージを作成します。
On Error Resume Next               ' エラーのトラップを留保します。
Err.Clear
Err.Raise 6                       ' "オーバーフロー" エラーを発生させます。
' エラーの発生をチェックした後、メッセージを表示します。
If Err.Number <> 0 Then
    Msg = "エラー番号 " & Str(Err.Number) & Err.Source & _" でエラーが発生しました。"
            & Chr(13) & Err.Description
    MsgBox Msg, , "エラー", Err.Helpfile, Err.HelpContext
End If

Oracle　追加 SQL 日付変換

to_date('" & wrow & "', 'yyyy/mm/dd hh24:mi:ss')

不要シート削除

    Application.DisplayAlerts = False
    For l = 2 To Worksheets.Count
        Sheets("Sheet" & l).Delete
    Next l
    Application.DisplayAlerts = True

    Sheets(2).Select
    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True

定義

Private Type r1     ' ユーザー定義型の作成。
    r101   As String
    r102   As String
End Type
Dim t1   As r1 ' r1
Dim t2   As r1 ' r1

Public Function pubGet() As Variant
    Dim varxxx(3) As Variant '戻り値
    varxxx(0) = ""
    varxxx(1) = ""
    varxxx(2) = ""
    pubGet = varxxx
End Function

Me.txt1 = pubGet(0)
Me.txt2 = pubGet(1)

フォルダー内のファイル抽出

Option Explicit
Sub sampleDir()
'フォルダー内のファイル抽出
Dim strFile As String
Dim tblInFile()
Dim lonCnt As Long
Dim i As Long
lonCnt = 0
ReDim tblInFile(0)
strFile = Dir("c:\ak\down\test\a\*")
If strFile <> "" Then
Do
lonCnt = lonCnt + 1
ReDim Preserve tblInFile(lonCnt)
tblInFile(lonCnt) = strFile

strFile = Dir
If Trim(strFile) = "" Then Exit Do
Loop
End If
For i = 1 To lonCnt
MsgBox tblInFile(i)
Next i
MsgBox Dir("c:\ak\down\test\a\a2.*")
End Sub

Access Lock情報

Sub AUTO_OPEN()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim lonRows As Long
Dim strDataSrc As String
str_datasrc= Worksheets(2).Cells(2, 1) 'MDBのファイル
Set cn = New ADODB.Connection
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & strDataSrc
cn.Open
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
Sheets(1).Select
Worksheets(1).Cells.Select
Selection.ClearContents
lonRows = 1
Worksheets(1).Cells(lonRows, 1) = rs.Fields(0).Name
Worksheets(1).Cells(lonRows, 2) = rs.Fields(1).Name
Worksheets(1).Cells(lonRows, 3) = rs.Fields(2).Name
Worksheets(1).Cells(lonRows, 4) = rs.Fields(3).Name
While Not rs.EOF
lonRows = lonRows + 1
Worksheets(1).Cells(lonRows, 1) = rs.Fields(0)
Worksheets(1).Cells(lonRows, 2) = rs.Fields(1)
Worksheets(1).Cells(lonRows, 3) = rs.Fields(2)
Worksheets(1).Cells(lonRows, 4) = rs.Fields(3)
rs.MoveNext
Wend
cn.Close
Set rs = Nothing
Set cn = Nothing
Worksheets(1).Cells(1, 1).Select
End Sub

Access テーブル名取得（ADO編）

Dim objADO As Object
Dim objCat As Object
Dim objRst As Object
Dim objtbl As Object

Sub getADOTable()
Set objADO = CreateObject("ADODB.Connection")
Set objCat = CreateObject("ADOX.Catalog")
objADO.Open "Driver={Microsoft Access Driver (*.mdb)}; DBQ=c:\ak\down\JRA.mdb;"
objCat.ActiveConnection = objADO
For Each objTbl In objCat.Tables
If objTbl.Type = "TABLE" Then
Debug.Print objTbl.Type & " : " & objTbl.Name
End If
Next objTbl
objADO.Close
Set objCat = Nothing
Set objADO = Nothing
End Sub

Sub getADOColumn()
Set objADO = CreateObject("ADODB.Connection")
Set objCat = CreateObject("ADOX.Catalog")
objADO.Open "Driver={Microsoft Access Driver (*.mdb)}; DBQ=c:\ak\down\JRA.mdb;"
objCat.ActiveConnection = objADO
Set objtbl = objCat.Tables("購入")
For i = 0 To objtbl.Columns.Count - 1
Debug.Print _
" Colu : " & objtbl.Columns(i).Name & _
" Type : " & objtbl.Columns(i).Type & _
" Size : " & objtbl.Columns(i).DefinedSize _
; " Attr : " & objtbl.Columns(i).Attributes
Next
objADO.Close
Set objtbl = Nothing
Set objCat = Nothing
Set objADO = Nothing
End Sub

西暦から和暦変換

1988	10	1	昭和	63	10	1	1988/10/01	S63.10.01
1988	11	1	昭和	63	11	1	1988/11/01	S63.11.01
1988	12	1	昭和	63	12	1	1988/12/01	S63.12.01
1989	1	1	昭和	64	1	1	1989/01/01	S64.01.01
1989	1	7	昭和	64	1	7	1989/01/07	S64.01.07
1989	1	8	平成	1	1	8	1989/01/08	H01.01.08
1989	2	1	平成	1	2	1	1989/02/01	H01.02.01
1926	12	24	大正	15	12	24	1926/12/24	T15.12.24
1926	12	25	昭和	1	12	25	1926/12/25	S01.12.25
1912	7	29	明治	45	7	29	1912/07/29	M45.07.29
1912	7	30	大正	1	7	30	1912/07/30	T01.07.30

Sub TEST()
Dim i As Long
For i = 1 To 11
Select Case Cells(i, 1)
Case 1868 To 1911
Cells(i, 5) = "明治"
Cells(i, 6) = Cells(i, 1) - 1867
Case 1912 To 1925
Cells(i, 5) = "大正"
Cells(i, 6) = Cells(i, 1) - 1911
If Cells(i, 1) = 1912 And Cells(i, 2) = 7 Then
If Cells(i, 3) < 30 Then
Cells(i, 5) = "明治"
Cells(i, 6) = Cells(i, 1) - 1867
End If
End If
Case 1926 To 1988
Cells(i, 5) = "昭和"
Cells(i, 6) = Cells(i, 1) - 1925
If Cells(i, 1) = 1926 And Cells(i, 2) = 12 Then
If Cells(i, 3) < 25 Then
Cells(i, 5) = "大正"
Cells(i, 6) = Cells(i, 1) - 1911
End If
End If
Case 1989 To 3000
Cells(i, 5) = "平成"
Cells(i, 6) = Cells(i, 1) - 1988
If Cells(i, 1) = 1989 And Cells(i, 2) = 1 Then
If Cells(i, 3) < 8 Then
Cells(i, 5) = "昭和"
Cells(i, 6) = Cells(i, 1) - 1925
End If
End If
Case Else
End Select
Next i
End Sub

SQLServerネイティブ接続

Sub test()
''ADOオブジェクト作成
'Set con = CreateObject("ADODB.Connection")
'Set rs = CreateObject("ADODB.Recordset")
''接続文字列
'connectionString = "Provider=Sqloledb;Data Source=" & sDBSever & ";Initial Catalog=" & sDBName & ";Connect Timeout=15" & ";user id=" & sLoginID & ";password=" & sPassWD & ""
'On Error GoTo Err_DBConnectOpen
''接続
'con.Open connectionString
'参照設定
'Microsoft ActiveX Data Objects 2.8 Library　（ダウンロード MDAC 2.8 SP1）
Dim con As New ADODB.Connection
Dim connectionString As String
Dim sDBSever As String
Dim sDBName As String
Dim sLoginID As String
Dim sPassWD As String
Dim rs As Recordset
Dim i As Long
sDBSever = "xxx-db"
sDBName = "xxxDataBase"
sLoginID = "xx"
sPassWD = "xx"
'接続文字列
connectionString = "Provider=Sqloledb;Data Source=" & sDBSever _
& ";Initial Catalog=" & sDBName _
& ";Connect Timeout=15" _
& ";user id=" & sLoginID _
& ";password=" & sPassWD _
& ""
On Error GoTo Err_DBConnectOpen
'接続
con.Open connectionString
'実行
Set rs = con.Execute("SELECT * FROM テーブル")
'結果
rs.MoveFirst
i = 1
Do Until rs.EOF = True
Cells(i, 1) = rs.fields(0).Value
Cells(i, 2) = rs.fields(1).Value
rs.MoveNext
i = i + 1
Loop
'切断
con.Close
Set con = Nothing
Exit Sub
'エラー処理
Err_DBConnectOpen:
MsgBox Err.Description
'後処理
If con.State <> ADODB.adStateClosed Then
con.Close
End If
Set con = Nothing
End Sub

'------------------------------------------------------
Option Explicit

Sub main()
Dim con As Object
Dim connectionString As String
Dim rs As Object
Dim sDBSever As String
Dim sDBName As String
Dim sLoginID As String
Dim sPassWD As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim strSql As String
Const SQL_INS001 As String = "INSERT INTO マスタ (テーブル, キー, 作成者, 作成プログラム, 更新者, 更新プログラム) VALUES ("

sDBSever = Worksheets("作成").Cells(5, 3)
sDBName = Worksheets("作成").Cells(6, 3)
sLoginID = Worksheets("作成").Cells(7, 3)
sPassWD = Worksheets("作成").Cells(8, 3)

'ADOオブジェクト作成
Set con = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

'接続文字列
connectionString = "Provider=Sqloledb;Data Source=" & sDBSever & ";Initial Catalog=" & sDBName & ";Connect Timeout=15" & ";user id=" & sLoginID & ";password=" & sPassWD & ""
On Error GoTo Err_DBConnectOpen
'接続
con.Open connectionString

i = 2
With Worksheets("一覧")
Do Until .Cells(i, 4).Value = ""
If .Cells(i, 1).Value = "○" Then
'テーブル削除
strSql = "DELETE FROM マスタ WHERE テーブル = '" & .Cells(i, 4).Value & "'"
con.Execute (strSql)
'テーブル追加
j = 2
With Worksheets(.Cells(i, 4).Value)
Do Until .Cells(j, 1).Value = ""
strSql = SQL_INS001
For k = 1 To 2
strSql = strSql & "'" & .Cells(j, k).Value & "',"
Next k
strSql = strSql & "'XXX','INSERT','XXX','INSERT')"
con.Execute (strSql)
j = j + 1
Loop
End With
End If
i = i + 1
Loop
End With

con.Close
Set rs = Nothing
Set con = Nothing

MsgBox "END"

Exit Sub

'エラー処理
Err_DBConnectOpen:
MsgBox i & "-" & j & "-" & Err.Description
Set rs = Nothing
Set con = Nothing

End Sub

'------------------------------------------------------
'接続
con.Open connectionString
'実行
con.CursorLocation = adUseClient
Set rs = con.Execute("SELECT * FROM テーブル")
Set Me.Recordset = rs
'結果
For i = 0 To rs.Fields.Count - 1
Me.Controls("txt" & Format(i, "0")).ControlSource = rs.Fields(i).Name
Next

VBA 文字列操作関数

セルの内容を置き換える

Object.Replace (What, Replacement, LookAt, SearchOrder,
　　　　　　　　　　　　　　　　MatchCase, MatchByte)

Object	Rangeオブジェクト
What	検索するデータを指定します [省略不可]
Replacement	検索したデータを置き換える文字列を指定します [省略不可]
LookAt	xlWhole　完全に同一なセルだけを検索　[省略可能]
	xlPart　一部分でも一致するセルの検索　[省略可能]
SeachOrder	検索方向を指定します。　xlByColumns　列方向に検索する [省略可能]
	xlByRows　行方向に検索する　[省略可能]
MatchCase	True　大文字と小文字を区別する　[省略可能]
	False　区別しない　[省略可能]
MatchByte	True　半角と全角を区別する　[省略可能]
	False　区別しない　[省略可能]

最終行と最終列の取得
Sub CellCnt()
Dim lntYCnt As Long
Dim intXCnt As Integer

lntYCnt = Worksheets("Sheet1").UsedRange.Rows.Count
intXCnt = Worksheets("Sheet1").UsedRange.Columns.Count
MsgBox "最終行は" & lntYCnt & "行、" & _
"最終列は" & intXCnt & "列です"
End Sub

指定した方法で文字列を変換する (StrConv関数)

StrConv　(String, Conversion, LCID)

設定項目	内容
String	変換対象の文字列を指定　[省略不可]
Conversion	変換の種類の合計値を指定（表参照）　[省略不可]
LCID	国別情報識別子 (LCID) を指定　[省略可能]

・引数conversionで指定する定数一覧（VbStrConv）

定数	値	内容
vbUpperCase	1	文字列を大文字に変換
vbLowerCase	2	文字列を小文字に変換
vbProperCase	3	文字列の各単語の先頭の文字を大文字に変換します。
vbWide	4	文字列内の半角文字を全角文字に変換
vbNarrow	8	文字列内の全角文字を半角文字に変換
vbKatakana	16	文字列内のひらがなをカタカナに変換
vbHiragana	32	文字列内のカタカナをひらがなに変換
vbUnicode	64	システムの既定のコードページを使って文字列をUnicodeに変換
vbFromUnicode	128	文字列をUnicodeからシステムの既定のコードページに変換

全角の小文字で入力されたワークシート中のアルファベットを、全て半角に変換し、さらには先頭の文字列を大文字に変換します。

Sub StrConvSamp1()
　　Dim c As Range

　　For Each c In ActiveSheet.UsedRange._
　　　　　　　　　　　　　SpecialCells(xlCellTypeConstants)
'---半角＋先頭大文字
　　　　c.Value = StrConv(c.Value, vbNarrow + vbProperCase)
　　Next

End Sub

A1形式（RANGE形式）、CELL形式へ変換

Sub test()
Debug.Print getRangeRtn(3, 2) '結果 B3
Debug.Print getCellRtn("C2") '結果　3
End Sub

Function getCellRtn(strCol As String) As Long
getCellRtn = Sheets(1).Range(strCol).Column
End Function

Function getRangeRtn(lonRow As Long, lonCol As Long) As String
getRangeRtn = Sheets(1).Cells(lonRow, lonCol).Address(False, False)
End Function

ブック内シート

Sub test()
Dim ws As Worksheet
Dim i As Long
i = 1
For Each ws In Worksheets
MsgBox ws.Name
Sheets(i).Select
i = i + 1
Next ws
End Sub

Join

Dim strTxt As Variant
Dim strTbl(4) As Variant
Dim i As Integer
strTxt = Array("a", "b", "c", "d", "e")
For i = 1 To 5
strTbl(i - 1) = strTxt(i - 1)
Next i
Debug.Print Join(strTbl, ",")

TextToColumns可変

Option Explicit
Sub import()
Dim i As Long
Dim j As Long
Dim lonFile As Long
Dim strFile As String
Dim ranPos As Range
Dim ranTmp As Range
Dim strText As String
Dim valInfo() As Variant

j = 6
ReDim valInfo(1 To j, 0 To 1)

strFile = "C:\ak\down\aaa.csv"
Worksheets(1).Activate

Range("A1").CurrentRegion.Select
Selection.Clear

Set ranPos = Range("A1")
lonFile = FreeFile
Open strFile For Input As #lonFile
i = 0
Do Until EOF(lonFile)
Line Input #lonFile, strText
ranPos.Offset(i).Value = strText
i = i + 1
Loop
Close #lonFile

For i = 1 To j
valInfo(i, 0) = i
valInfo(i, 1) = 2
Next i

Set ranTmp = Range(ranPos, ranPos.End(xlDown))
'ranTmp.Replace What:="'", Replacement:=""
ranTmp.TextToColumns DataType:=xlDelimited, Comma:=True, FieldInfo:=valInfo
Cells.Select
Cells.EntireColumn.AutoFit
ranPos.Cells.Select
Set ranPos = Nothing
Set ranTmp = Nothing
End Sub

COBOL NUM

Option Explicit
Sub main()
Dim lonIn As Long
Dim lonOt As Long
Dim strInFile As String
Dim strOtFile As String
Dim strInText As String
Dim lonNum As Long
Dim lonSpc As Long
strInFile = "C:\ak\down\SI.cbl"
strOtFile = "C:\ak\down\SO.cbl"
lonIn = FreeFile
Open strInFile For Input As #lonIn
lonOt = FreeFile
Open strOtFile For Output As #lonOt
lonNum = 1
Do While Not EOF(lonIn)
DoEvents
Line Input #lonIn, strInText
lonSpc = 0
If 72 > lonLen(strInText) Then
lonSpc = 72 - lonLen(strInText)
If lonSpc = 72 Then
lonSpc = 66
End If
End If
Print #lonOt, Format(lonNum, "000000") & strMid(strInText, 7, 66) & Space(lonSpc)
lonNum = lonNum + 1
Loop
Close #lonIn
Close #lonOt
MsgBox "END"
End Sub
Function strMid(strItm As String, lonSta As Long, lonLen As Long) As String
strMid = StrConv(MidB(StrConv(strItm, vbFromUnicode), lonSta, lonLen), vbUnicode)
End Function
Function lonLen(str As String) As Long
lonLen = LenB(StrConv(str, vbFromUnicode))
End Function

パス、ファイルを分割表示

Sub aaa()
Dim objFs As Object
Dim strPath As String
Dim strFile As String
Const aaa = "C:\ak\down\aaa.txt"
'1
strPath = Left(aaa, InStrRev(aaa, "\"))
strFile = Mid(aaa, InStrRev(aaa, "\") + 1)
MsgBox strPath & vbCrLf & strFile
'2
strPath = Left(aaa, Len(aaa) - Len(Dir(aaa)))
strFile = Dir(aaa)
MsgBox strPath & vbCrLf & strFile
'3
Set objFs = CreateObject("Scripting.FileSystemObject")
strFile = objFs.GetFileName(aaa)
strPath = objFs.GetParentFolderName(aaa)
Set objFs = Nothing
MsgBox strPath & vbCrLf & strFile & "（\なし）"
End Sub

セルの重複

Sub test()
Dim i As Long
Dim j As Long
Dim rowCol As Collection

'コレクション生成
Set rowCol = New Collection

i = 1
Do While Sheets(1).Cells(i, 1) <> ""

'エラーを無視
'現在の行番号をKEY値で格納
'KEY値は、列１，２，４であり、繋げる。
On Error Resume Next
rowCol.Add i, Sheets(1).Cells(i, 1).Value & Sheets(1).Cells(i, 2).Value & Sheets(1).Cells(i, 4).Value
On Error GoTo 0

i = i + 1
Loop

'重複行を削除したデータを格納するシートを削除
Sheets(2).Cells.Clear

'コレクションをループ
'重複がないデータを新たに生成
MsgBox rowCol.Count
j = 1
For Each tempj In rowCol
Sheets(1).Rows(CInt(tempj)).Copy Sheets(2).Rows(j)
j = j + 1
Next
Set rowCol = Nothing
End Sub

Folderを選択する

Sub test1()

MsgBox FolderPath

End Sub

Function FolderPath() As String

Dim Shell As Object

Set Shell = CreateObject("Shell.Application") _
.BrowseForFolder(0, "フォルダを選択してください", 0, "c:\")

If Shell Is Nothing Then
FolderPath = ""
Else
FolderPath = Shell.Items.Item.Path
End If

End Function

Sub test2()

MsgBox FolderPath2

End Sub

Function FolderPath2() As String
'2002以降で動作

With Application.FileDialog(msoFileDialogFolderPicker)

If .Show = -1 Then 'アクションボタンがクリックされた
FolderPath2 = .SelectedItems(1)
Else 'キャンセルボタンがクリックされた
FolderPath2 = ""
End If
End With

End Function

全角半角変換

Dim intConv As Integer
Dim intFil1 As Integer
Dim intFil2 As Integer
Dim strLine As String

intFil1 = FreeFile
Open Cells(2, 2) For Input Access Read As #intFil1
intFil2 = FreeFile
Open Cells(2, 2) & ".txt" For Output Access Write As #intFil2

If Cells(3, 2) = "全角" Then
intConv = 4 'vbWide 全角へ
Else
intConv = 8 'vbNarrow 半角へ
End If

Do While Not EOF(intFil1)
Line Input #intFil1, strLine
Print #intFil2, StrConv(strLine, intConv)
Loop

Close #intFil1
Close #intFil2

MsgBox "END"

文字列から整数だけを取り出す

Sub test()
Dim str As String
Dim i As Integer
Dim j As Integer
Dim strOut As Variant
str = "YEN120-YEN150"
i = Len(str)
For j = 1 To i
If Mid(str, j, 1) >= 0 And Mid(str, j, 1) <= 9 Then
strOut = strOut & Mid(str, j, 1)
End If
Next
MsgBox strOut

'連続数字
Dim str As String
Dim strOut As String
str = "YEN200.-"
Do While Len(str)
If str Like "[0-9]*" Then
strOut = Val(str)
Exit Do
End If
str = Mid(str, 2)
Loop
MsgBox strOut
End Sub

60進数の足し算

'60進数の加算
Sub test1()
Dim lonSeisu As Long
Dim lonShosu As Long
Dim i As Integer
Dim dblTime(4) As Double

dblTime(1) = 1.29
dblTime(2) = 0.5
dblTime(3) = 12
dblTime(4) = 12

For i = 1 To 4
lonSeisu = lonSeisu + Int(dblTime(i))
lonShosu = lonShosu + (dblTime(i) - Int(dblTime(i))) * 100
Next i
lonSeisu = lonSeisu + Int(lonShosu / 60)
lonShosu = lonShosu Mod 60

MsgBox lonSeisu + lonShosu / 100

End Sub

'60進数の加算（Excel対応関数）
Sub test2()
MsgBox add60(1.29, 0.5, 12, 12)
End Sub

Function add60(ParamArray varParm() As Variant)
Dim lonSeisu As Long
Dim lonShosu As Long
Dim i As Long
Dim varNum As Variant
Dim varArray As Variant

For Each varNum In varParm
' add60(1.29, 0.5, 12, 12)
If IsNumeric(varNum) Then
lonSeisu = lonSeisu + Int(varNum)
lonShosu = lonShosu + (varNum - Int(varNum)) * 100
End If
'add60(A1:A4)
If IsArray(varNum) Then
For Each varArray In varNum
lonSeisu = lonSeisu + Int(varArray)
lonShosu = lonShosu + (varArray - Int(varArray)) * 100
Next varArray
End If
Next varNum
lonSeisu = lonSeisu + Int(lonShosu / 60)
lonShosu = lonShosu Mod 60
add60 = lonSeisu + lonShosu / 100
End Function

VBAマクロ　ブック　シート　保護

'全てのシートに『1111』というパスワードを設定してシートの保護をする。
Sub test()
　Dim W As Worksheet
　For Each W In Worksheets
　　W.Protect Password:="1111"
　Next W
End Sub

'全てのシートに設定された『1111』のパスワードのシートの保護を解除する。
Sub test()
　Dim W As Worksheet
　For Each W In Worksheets
　　W.Unprotect Password:="1111"
　Next W
End Sub

パスワードを設定したブックの保護を行うには？
'アクティブブックに『1111』のパスワードでブックの保護をする。
Sub test()
　ActiveWorkbook.Protect Password:="1111"
End Sub

'アクティブブックに設定された『1111』のパスワードのブックの保護を解除する。
Sub test()
　ActiveWorkbook.Unprotect Password:="1111"
End Sub

カーソル　砂時計　Esc停止

Sub test()

Dim waitTime As Variant
Dim sttime As Date
Dim edtime As Date
Dim i As Long
Dim j As Long
Dim cnt As Long

Application.EnableCancelKey = xlErrorHandler

On Error GoTo ErrHandler

cnt = Cells(1, 1) '10000

'waitTime = Now + TimeValue("0:00:10")
'Application.Wait waitTime

'砂時計の形状
Application.Cursor = xlWait

sttime = Now()

' 無限ループを生成する
'Do

'Loop

'ループ
For i = 1 To cnt
For j = 1 To cnt
Next j
Next i

edtime = Now()

'カーソルの形状を元に戻す
Application.Cursor = xlNormal

MsgBox "経過時間=" & Abs(DateDiff("s", sttime, edtime)) & "秒"

Exit Sub

ErrHandler:

'カーソルの形状を元に戻す
Application.Cursor = xlNormal

Select Case Err.Number
Case 18
'Escによる中断
If MsgBox("中断しますか？", vbQuestion + vbYesNo) = vbNo Then
Resume
End If
Case Else
MsgBox "予期しないエラーが発生しました", vbExclamation
End Select

MsgBox "Error No =" & Err.Number & vbCrLf & "Error Msg=" & Err.Description

End Sub

ByRefとByValの違い

Option Explicit

Sub test()
Dim Argument1 As Long

Argument1 = 100
Call MyProcByRef(Argument1)
MsgBox Argument1 '200

Argument1 = 100
Call MyProcByVal(Argument1)
MsgBox Argument1 '100
End Sub

'引数を ByRef:参照渡しで宣言すると、プロシージャの呼び出し側にも影響を与える
Private Sub MyProcByRef(ByRef Argument2 As Long)
Argument2 = 200
End Sub

'通常は、ByVal:値渡し
Private Sub MyProcByVal(ByVal Argument3 As Long)
Argument3 = 300
End Sub

CSVファイルをひとつにまとめる

Option Explicit
Const TYPE_CSV = "csv"
Const TYPE_TXT = "txt"

Sub main()
Dim strPath As String
Dim strRet() As String
Dim lonCnt As Long

strPath = Cells(1, 1).Value

''ファイル名を取得
strRet = getFile(strPath)

''ファイルを結合して出力
lonCnt = UBound(strRet)
If putFile(strPath, strRet, lonCnt) = True Then
MsgBox lonCnt & "件出力", vbInformation
Else
MsgBox "失敗", vbExclamation
End If

End Sub

''ファイルを結合して出力
Function putFile(strPath As String, strFile() As String, ByRef lonCnt As Long) As Boolean
Dim FSO As Object
Dim i As Long
Dim strInFile As String
Dim strOutFile As String

On Error GoTo ErrHandler

putFile = True
Set FSO = CreateObject("Scripting.FileSystemObject")

strOutFile = strPath & "\" & strFile(1) & "-" & strFile(lonCnt) & "." & TYPE_TXT

For i = 1 To lonCnt
strInFile = strPath & "\" & strFile(i) & "." & TYPE_CSV
If i = 1 Then
FSO.CreateTextFile(strOutFile).Write FSO.OpenTextFile(strInFile).ReadAll
Else
'テスト
'Err.Clear
'Err.Raise 6 ' "オーバーフロー" エラーを発生
strInFile = strPath & "\" & strFile(i) & "." & TYPE_CSV
FSO.OpenTextFile(strOutFile, 8).Write FSO.OpenTextFile(strInFile).ReadAll
End If
Next i
lonCnt = i - 1
Set FSO = Nothing

Exit Function

ErrHandler:
putFile = False
If Not FSO Is Nothing Then Set FSO = Nothing
MsgBox i - 1 & "件出力", vbInformation
MsgBox ("Error No =" & Err.Number & vbCr & "Error Msg=" & Err.Description)
End Function

''ファイル名を取得
Function getFile(strPrm) As Variant
Dim FSO As Object
Dim varFile As Variant
Dim strFile() As String
Dim lonCnt As Long
Dim i As Long
Dim strRet() As String

Set FSO = CreateObject("Scripting.FileSystemObject")

ReDim strFile(FSO.GetFolder(strPrm).Files.Count)
For Each varFile In FSO.GetFolder(strPrm).Files
If LCase(FSO.GetExtensionName(varFile.Name)) = TYPE_CSV Then
lonCnt = lonCnt + 1
strFile(lonCnt) = FSO.GetBaseName(varFile.Name)
End If
Next varFile

ReDim strRet(lonCnt)
If lonCnt <> 0 Then
For i = 1 To lonCnt
strRet(i) = strFile(i)
Next i
End If
getFile = strRet

Set FSO = Nothing
End Function

環境変数

Sub WSH_Ex()
'Windows Script Host Oject Model
Dim objNW As WshNetwork
Set objNW = New WshNetwork
With objNW
Debug.Print .UserName
Debug.Print .ComputerName
Debug.Print .UserDomain
End With
Set objNW = Nothing
End Sub
Sub WSH_Ex1()
Dim objWshShell As Object
Dim objWshSysEnv As Object

Set objWshShell = CreateObject("WScript.Shell")
'Set objWshSysEnv = objWshShell.Environment("SYSTEM") 'Microsoft Windows NT/2000
Set objWshSysEnv = objWshShell.Environment("Process") 'Windows 95/98/Me
MsgBox objWshSysEnv("COMPUTERNAME")
Set objWshShell = Nothing

End Sub

Sub Environ_Ex()
'環境変数の値を取得する (Environ関数)
Dim i As Long
i = 1
Do Until Environ(i) = ""
Debug.Print i & ":" & Environ(i)
i = i + 1
Loop
End Sub

セルの周りに罫線を引く

Option Explicit
'Office Space ワークシートセルの周りに罫線を引く
'http://technet.microsoft.com/ja-jp/library/ee692886.aspx

Sub ee692886()

Dim objExcel As Object
Dim objWorkbook As Object
Dim objWorksheet As Object
Dim i As Integer
Dim j As Integer
Dim k As Integer

Const xlContinuous = 1
Const xlThick = 4

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
Set objWorksheet = objWorkbook.Worksheets(1)
k = 1
For i = 1 To 5
For j = 1 To 5
objWorksheet.Cells(i, j) = k
k = k + 1
Next
Next

objWorksheet.UsedRange.Borders.LineStyle = xlContinuous
objWorksheet.UsedRange.Borders.Color = RGB(255, 0, 0)
objWorksheet.UsedRange.Borders.Weight = xlThick

End Sub

Sub ee692886_1()
Dim objExcel As Object
Dim objWorkbook As Object
Dim objWorksheet As Object
Dim i As Integer
Dim j As Integer
Dim k As Integer

Const xlContinuous = 1

Set objWorkbook = Workbooks(ActiveWorkbook.Name)
Set objWorksheet = objWorkbook.Worksheets(1)
k = 1
For i = 1 To 5
For j = 1 To 5
objWorksheet.Cells(i, j) = k
k = k + 1
Next
Next

objWorksheet.UsedRange.Borders.LineStyle = xlContinuous
objWorksheet.UsedRange.Borders.Color = RGB(255, 0, 0)

End Sub

？？？

SUB

？？？

SUB

サ　ン　プ　ル

		定数
		エクセルブックのコントロール
		バイナリファイルの入出力を制御する方法
		クリップボードへ情報を送信する方法
		外部データベースにアクセスする方法
		ファイル入出力に関するサンプル（シーケンシャルファイル編)
		Shell 関数で起動したアプリケーションの終了を認識する方法
		odbc select　参照設定でDAO
		ado select
		ado insert
		dao [参照設定] で[Microsoft DAO 3.0 ObjectLibrary]
		xlodbc [参照設定]で[XLODBC.XLA]
		ファイル名に関連付けられている実行可能ファイルの名前を取得
		ディレクトリからファイル名を取得　デジカメプリント用に利用しています
		エクセルデータをアクセスに書き込む
		ツールバーに登録（おみくじ）
		エクセル＜－＞テキスト変換
		カレンダー（祝日自動計算）
		XLS一括印刷（ブック単位の印刷）
		エクセルでIEのオープン＆クローズ
		ブレイク処理サンプルプログラム　ソース
		マッチング処理サンプルプログラム　ソース
		EUC 参照設定でDAO
		配列
		名前付きセル範囲