ak VBA

　 サ　ン　プ　ル

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

Option Explicit
'ieから別のieへ値をセット
Sub getIEValues()
Dim objie As Object
Dim ShWins As Object
Dim ie As Object
Dim strURL As String
Dim strIeType As String
Dim strDocument As String
Dim stritem1 As String
Dim stritem2 As String
Dim stritem3 As String
Dim x As Long

' Set objie = CreateObject("InternetExplorer.Application")
' objie.Navigate "vba/in.html"
' objie.Visible = True
'
' Do While objie.Busy
' Application.Wait (Now + TimeValue("0:00:03"))
' Loop

On Error Resume Next
'Set objIE = GetObject("", "InternetExplorer.Application")
Set objie = CreateObject("Shell.Application")
Set ShWins = objie.Windows()
For Each ie In ShWins
'URL取得
strURL = ie.LocationURL
'タイプ取得
strIeType = ie.Type
If strIeType = "HTML ドキュメント" Then
'タイトル取得
strDocument = ie.document.Title
If strDocument = "===input===" Then
'アイテムサーチ用
'For x = 0 To ie.document.all.Length - 1
' Debug.Print x, ie.document.all(x).innerText
'Next
'MsgBox ie.document.all(7).innerText
'MsgBox ie.document.getElementById("T1")
'アイテム取得
stritem1 = ie.document.in.I1.Value
stritem2 = ie.document.in.I2.Value
stritem3 = ie.document.in.I3.Value
End If
If strDocument = "===output===" Then
'アイテムセット
ie.document.out.O1.Value = stritem1
ie.document.out.O2.Value = stritem2
ie.document.out.O3.Value = stritem3
End If
End If
Next

Set objie = Nothing
Set ShWins = Nothing

End Sub

'フレームの時
ie.document.frames("フレーム名").フォーム名.項目.Value = "111"

----------------------------------------------------------------

Private Sub Test()
Dim objie As Object
Dim ShWins As Object
Dim ie As Object
Dim strURL As String
Dim strIeType As String
Dim strDocument As String

    On Error Resume Next
        Set objie = CreateObject("Shell.Application")
        Set ShWins = objie.Windows()
        For Each ie In ShWins
            'URL取得
            strURL = ie.LocationURL
            'タイプ取得
            strIeType = ie.Type
            If strIeType = "HTML ドキュメント" Then
                'タイトル取得
                strDocument = ie.Document.TITLE
                If strDocument = "HTML title" Then
                    'アイテムセット
                    ie.Document.form1.USERID.Value = gstrCha2
                    ie.Document.form1.Passwd.Value = gstrCha3
                End If
            End If
        Next
        Set objie = Nothing
        Set ShWins = Nothing
End Sub

----------------------------------------------------------------

Sub test()
Dim objie As Object
Dim ShWins As Object
Dim ie As Object
Dim strURL As String
Dim strIeType As String
Dim strDocument As String
Dim strwk As String
Dim i As Long
    On Error Resume Next
    Set objie = CreateObject("Shell.Application")
    Set ShWins = objie.Windows()
    For Each ie In ShWins
        'URL取得
        strURL = ie.LocationURL
        'タイプ取得
        strIeType = ie.Type
        If strIeType = "HTML ドキュメント" Then
            'タイトル取得
            strDocument = ie.document.Title
            If strDocument = "HTML title" Then
                For i = 1 To 50000
                    If Cells(i, 2) = "" Then Exit For
                    strwk = Cells(i, 2)
                    ie.document.getElementsByName(strwk).Item(0).Value = Cells(i, 3)
                Next i
            End If
        End If
    Next
    Set objie = Nothing
    Set ShWins = Nothing
End Sub

データ型変換関数

CBool(expression)

CByte(expression)

CCur(expression)

CDate(expression)

CDbl(expression)

CDec(expression)

CInt(expression)

CLng(expression)

CSng(expression)

CVar(expression)

CStr(expression)

引数 expression には任意の文字列式または数式を指定します。

戻り値のデータ型

次に示すように関数名によって戻り値のデータ型が異なります。

関数戻り値のデータ型引数 expression の範囲
CBool ブール型 (Boolean) 任意の有効な文字列または数式
CByte バイト型 (Byte) 0 ～ 255
CCur 通貨型 (Currency) -922,337,203,685,477.5808 ～
922,337,203,685,477.5807
CDate 日付型 (Date) 任意の有効な日付式
CDbl 倍精度浮動小数点数型 (Double)
-1.79769313486231E308 ～ -4.94065645841247E-324 (負の値)。
4.94065645841247E-324 ～ 1.79769313486232E308 (正の値)。

CDec 10 進型 (Decimal) 小数点以下が 0 桁 (小数部分を持たない数値) の場合、
-79,228,162,514,264,337,593,543,950,335 ～
79,228,162,514,264,337,593,543,950,335。
小数点以下 28 桁の数値の場合、
-7.9228162514264337593543950335 ～ 7.9228162514264337593543950335。
絶対値の最小値は 0 を除いた場合、0.0000000000000000000000000001 です。

CInt 整数型 (Integer) -32,768 ～ 32,767。小数部分は丸められます。
CLng 長整数型 (Long) -2,147,483,648 ～ 2,147,483,647。小数部分は丸められます。
CSng 単精度浮動小数点数型 (Single) -3.402823E38 ～ -1.401298E-45 (負の値)、
および 1.401298E-45 ～ 3.402823E38 (正の値)。
CVar バリアント型 (Variant) 数値の場合は倍精度浮動小数点数型の範囲と同じ。
数値以外の場合は、文字列型の範囲と同じ。
CStr 文字列型 (String) CStr 関数の戻り値は引数 expression により異なります。

経過時間

'経過時間
Public Function getKeikaJikan(DATE1 As String, TIME1 As String, DATE2 As
String, TIME2 As String) As String
    Dim dt As Long
    Dim h As String
    Dim m As String
    Dim s As String
    Dim d As String
    If IsNull(DATE1) Or IsNull(TIME1) Or IsNull(DATE2) Or IsNull(TIME2) Then
        getKeikaJikan = 0
        Exit Function
    End If
    dt = Abs(DateDiff("n", Format(DATE1, "yyyy/mm/dd") & " " & _
        TimeSerial(Left(TIME1, 2), Right(TIME1, 2), "00"), _
        Format(DATE2, "yyyy/mm/dd") & " " & _
        TimeSerial(Left(TIME2, 2), Right(TIME2, 2), "00")))
    h = Format(Int(dt / 60), "00")
    m = Format((dt Mod 60), "00")
    getKeikaJikan = h & "-" & m
End Function

'経過時間
Public Function getKeikaJikan1(DATE1 As Date, DATE2 As Date) As String
    Dim dt As Long
    Dim h As String
    Dim m As String
    Dim s As String
    Dim d As String
    If IsNull(DATE1) Or IsNull(DATE2) Then
        getKeikaJikan1 = 0
        Exit Function
    End If
    dt = Abs(DateDiff("n", DATE2, DATE1))
    h = Format(Int(dt / 60), "00")
    m = Format((dt Mod 60), "00")
    getKeikaJikan1 = h & "-" & m
End Function

ファイルの保存

On Error Resume Next
Dim TargetFile As Workbook

'Workbooks.Open Filename:="C:\xxxx\temp.xlt"
Set TargetFile = Workbooks.Add 'ActiveWorkbook
With TargetFile
.Saved = True
.SaveAs Filename:="test.xls"
.Close
End With
Set TargetFile = Nothing

分から時間を計算

Public Function getTime(dt As Long) As Double
Dim hh As Long
Dim mm As Double
    getTime = 0
    mm = 0
    hh = 0
    mm = dt Mod 60
    hh = (dt - mm) / 60
    getTime = hh + (mm / 100)
End Function

保存せずに終了

ActiveWorkbook.Saved = True '保存せずに終了
Application.Quit 'EXCEL終了

区切り文字で文字を切る

varTmp = Split(strData, vbTab)
For i = 0 To UBound(varTmp)
Debug.Print varTmp(i)
Next i

ファイル名取得

MsgBox Dir("C:\Sample\hoge.xls")

パスからフォルダー名取得

Public Function getFolderName(strFile As String) As String
    For m = Len(strFile) To 1 Step -1
        If Mid(strFile, m, 1) = "\" Then Exit For
    Next m
    getFolderName = Left(strFile, Len(strFile) - m)
End Function

Accessマクロ起動

Dim strDir As String, strApp As String, strMcr As String
Dim RetVal As Variant
strDir = "C:\Program Files\Microsoft Office\OFFICE11\MSACCESS.EXE "
strApp = "d:\test.MDB"
strMcr = " /X マクロ名.マクロ名"
RetVal = Shell(StrDir & StrApp & StrMcr, 2)

Environ関数で環境変数の値を取得

Private Sub test()
    Dim i As Long
    For i = 1 To 40
        Debug.Print i, Environ(i)
    Next i
End Sub

Environ("LOGONSERVER")

小文字大文字変換

Sub cnv()
Dim FileNumber1 As Long
Dim FileNumber2 As Long
Dim inLine As String
Dim outLine As String
FileNumber1 = FreeFile
Open Worksheets(1).Cells(3, 4) For Input Access Read As #FileNumber1
FileNumber2 = FreeFile
Open Worksheets(1).Cells(4, 4) For Output Access Write As #FileNumber2
Do While Not EOF(FileNumber1)
Line Input #FileNumber1, inLine
'大文字変換
If Worksheets(1).Cells(3, 2) = "○" Then
outLine = UCase(inLine)
Print #FileNumber2, outLine
End If

'小文字変換
If Worksheets(1).Cells(3, 3) = "○" Then
outLine = LCase(inLine)
Print #FileNumber2, outLine
End If

Loop
Close #FileNumber1
Close #FileNumber2

MsgBox "完"
End Sub

Office アプリケーションのパスを調べる方法

'アプリケーション ProgId
'Microsoft Access Access.Application
'Microsoft Excel Excel.Application
'Microsoft Outlook Outlook.Application
'Microsoft PowerPoint Powerpoint.Application
'Microsoft Word Word.Application
'Microsoft FrontPage FrontPage.Application

Option Explicit

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) _
As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal lpReserved As Long, lpType As Long, _
ByVal lpData As String, lpcbData As Long) As Long
'Note that if you declare the lpData parameter as String,
'you must pass it ByVal.

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Const REG_SZ As Long = 1
Const KEY_ALL_ACCESS = &H3F
Const HKEY_LOCAL_MACHINE = &H80000002

Private Sub Command1_Click()
Dim hKey As Long
Dim RetVal As Long
Dim sProgId As String
Dim sCLSID As String
Dim sPath As String
sProgId = "Excel.Application"
'First, get the clsid from the progid
'from the registry key:
'HKEY_LOCAL_MACHINE\Software\Classes\<PROGID>\CLSID
RetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Software\Classes\" & _
sProgId & "\CLSID", 0&, KEY_ALL_ACCESS, hKey)
If RetVal = 0 Then
Dim n As Long
RetVal = RegQueryValueEx(hKey, "", 0&, REG_SZ, "", n)
sCLSID = Space(n)
RetVal = RegQueryValueEx(hKey, "", 0&, REG_SZ, sCLSID, n)
sCLSID = Left(sCLSID, n - 1) 'drop null-terminator
RegCloseKey hKey
End If

'Now that we have the CLSID, locate the server path at
'HKEY_LOCAL_MACHINE\Software\Classes\CLSID\
' {xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxx}\LocalServer32
RetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
"Software\Classes\CLSID\" & sCLSID & "\LocalServer32", 0&, _
KEY_ALL_ACCESS, hKey)
If RetVal = 0 Then
RetVal = RegQueryValueEx(hKey, "", 0&, REG_SZ, "", n)
sPath = Space(n)
RetVal = RegQueryValueEx(hKey, "", 0&, REG_SZ, sPath, n)
sPath = Left(sPath, n - 1)
MsgBox sPath
RegCloseKey hKey
End If

End Sub

名前オブジェクト削除

Sub ClearAllNames()
　Dim objName As Name
　For Each objName In ActiveWorkbook.Names
　　objName.Delete
　Next objName
End Sub

時間計算

Dim dtdDate As Date
dtdDate = Now() 'CDate("2007/02/13 22:46:00")
dtdDate = DateTime.DateAdd("n", 3, dtdDate)
MsgBox Format(dtdDate, "yyyy/MM/dd hh:mm:ss")
If Second(dtdDate) = 15 Then
MsgBox "just"
End If

５秒ウェイト

Dim PauseTime, Start, Finish, TotalTime

    PauseTime = 5                ' 中断時間を設定します。
    Start = Timer                ' 中断の開始時刻を設定します。
    Do While Timer < Start + PauseTime
        DoEvents                ' 他のプロセスに制御を渡します。
    Loop
    Finish = Timer                ' 中断の終了時刻を設定します。
    TotalTime = Finish - Start    ' 実際の中断時間を計算します。
    MsgBox "実行を " & TotalTime & " 秒間中断しました。"

年度求める

Function nendo(ym As String) As String
Dim yy As String
Dim mm As String
yy = Left(ym, 4)
mm = Mid(ym, 5, 2)
If mm = "01" Or mm = "02" Or mm = "03" Then
yy = yy - 1
End If
nendo = yy
End Function

プラス１ヶ月

if mm <> 12 then
yyyymmdd + 100
else
yyyymmdd + 8900
end if

名前の変更

Name oldpathname As newpathname
Name strdatapass & "dat.new" As strdatapass & "dat.mdb"

初期化

Erase StrVarArray
固定サイズの配列の場合は要素を再初期化し、
動的配列の場合は割り当てたメモリ解放

スペース埋め

Print #fnum, wkdata; Spc(38)

制御をオペレーティングシステムに渡すフロー制御関数

DoEvents

5秒待つ

If Application.Wait(Now + TimeValue("0:00:05")) Then
MsgBox "time up"
End If

Cells形式からRange形式に変換

MsgBox Cells(1, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)

全角から半角への変換

Sub test()

'全角漢字からひらがなに変換
Dim strItem As String
strItem = StrConv(Application.GetPhonetic("田中"), vbHiragana)
MsgBox strItem

'全角漢字から全角カタカナに変換
strItem = Application.GetPhonetic("田中")
MsgBox strItem

'全角漢字から半角カタカナに変換
strItem = StrConv(Application.GetPhonetic("田中"), vbNarrow)
MsgBox strItem

'全角英数字から半角英数字に変換
strItem = StrConv(Application.GetPhonetic("ＡＢ３－１Ｃ"), vbNarrow)
MsgBox strItem

End Sub

Cells形式とRange形式のコラボ

Range(Cells(1, 1), Cells(3, 1)).Select

Excel で列番号を英文字に変換する方法

Function ConvertToLetter(iCol As Integer) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int((iCol - 1) / 26)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function

簡易取捨五入

+0.5 関数
123.54 124.04 124
123.44 123.94 123

-0.5
-123.54 -124.04 -124
-123.44 -123.94 -123

Function 関数(dbl As Double) As Long
If dbl > 0 Then
関数 = Int(dbl+0.5)
Else
関数 = Fix(dbl-0.5)
End If
End Function

セルダブルクック

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 3 And Target.Row = 7 Then
Select Case Target.Value
Case ""
Target.Value = "一回目"
Cells(Target.Row, 2).Value = "グー"
Case "一回目"
Target.Value = "二回目"
Cells(Target.Row, 2).Value = "チョキ"
Case "二回目"
Target.Value = "三回目"
Cells(Target.Row, 2).Value = "パー"
Case "三回目"
Target.Value = ""
Cells(Target.Row, 2).Value = Empty
Case Else
MsgBox "何回目？", vbInformation
End Select
Cancel = True
End If
End Sub

CL起動

lngRet = clsFtp.CmdFile("RCMD ADDLIBLE LIB(xxxOBJ)", ftpAscii)
'lngRet = clsFtp.CmdFile("QUOTE RCMD SBMJOB CMD(CALL PGM(pgm)PARM('YYMMDD')) JOB(pgm) LOG(4 00 *SECLVL)", ftpAscii)
lngRet = clsFtp.CmdFile("RCMD SBMJOB CMD(CALL PGM(pgm)PARM('YYMMDD')) JOB(pgm) LOG(4 00 *SECLVL)", ftpAscii)

ファイルの自動保存

Option Compare Text

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Const strConst1 As String = "C:\月度実績_BackUp"
Const strConst2 As String = "xx.XLS"
If ThisWorkbook.Name = strConst2 Then
ThisWorkbook.SaveCopyAs strConst1 & "\" & Replace(ThisWorkbook.Name, ".",Format(Now, "_yymmdd_hh_nnssC."))
End If
End Sub

Private Sub Workbook_Open()
Const strConst1 As String = "C:\月度実績_BackUp"
Const strConst2 As String = "xx.XLS"
If ThisWorkbook.Name = strConst2 Then
If Dir(strConst1, 16) = "" Then
MkDir strConst1
End If
ThisWorkbook.SaveCopyAs strConst1 & "\" & Replace(ThisWorkbook.Name, ".",Format(Now, "_yymmdd_hh_nnssO."))
End If
End Sub

ファイルコピー

FileCopy outfile, infile

Excelファイルが開かれているか？

Sub test()
Dim Path As String
Dim Count As Long
Dim Book As Variant
Path = "c:\xxx.xls"
Count = Application.Workbooks.Count
Set Book = GetObject(Path)
If Count <> Application.Workbooks.Count Then
Book.Close
Set Book = Nothing
MsgBox "Not Open"
ElseIf Book.Application Is Application Then
MsgBox "Open"
Else
MsgBox "No"
End If
End Sub

重複値を除く値をテーブルにストア

Sub TBLSTR()
Dim tbl(100) As String
Dim i As Long
Dim j As Long
Dim k As Long
k = 1
For j = 1 To 100
    tbl(j) = ""
Next j
For i = 2 To Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
    For j = 1 To 100
        If tbl(j) = Worksheets("sheet1").Cells(i, 1) Then
            Exit For
        End If
    Next j
    If j = 101 Then
        tbl(k) = Worksheets("sheet1").Cells(i, 1)
        k = k + 1
    End If
Next i
For i = 1 To k - 1
    MsgBox tbl(i)
Next i
End Sub

スペース埋め

Function spaceSet(ByRef x_str As String, x_len As Long) As String
    If Len(x_str) = 0 Then
        spaceSet = Space(x_len)
    ElseIf Len(x_str) = x_len Then
        spaceSet = x_str
    ElseIf Len(x_str) > x_len Then
        spaceSet = Right(x_str, x_len)
    ElseIf Len(x_str) < x_len Then
        spaceSet = x_str & Space(x_len - Len(x_str))
    End If
End Function

文字の繰り返し

Dim MyString
MyString = String(5, "*")            ' "*****" を返します。
MyString = String(5, 42)            ' "*****" を返します。
MyString = String(10, "ABC")        ' "AAAAAAAAAA" を返します。
Space(5)
' Spc 関数は、Print # ステートメントの中で使うことができます。
Print #1, "ここから"; Spc(10); "ここまでの間に 10 個のスペースが挿入されます。"

ファイル選択（開く）　ファイル選択ダイアログ

Dim Msg As String
Dim Style As String
Dim Response As Long
Const Title = "システム名"
Const Ctxt = 1000
Const Help = ""

Dim myfile As String
Dim myfolder As String

    myfile = Application.GetOpenFilename("CSV ファイル (*.csv), *.csv", , , ,
False)
    If myfile = "False" Then
        Msg = "キャンセルが選択されました" & vbCrLf & "処理を中止します。"
        Style = vbInformation
        Response = MsgBox(Msg, Style, Title, Help, Ctxt)
    Else
        Worksheets("sheet1").Cells(8, 7) = myfile
    End If
    For i = Len(myfile) To 1 Step -1
        If Mid(myfile, i, 1) = "\" Then
            Exit For
        End If
    Next i
    myfolder = Mid(myfile, 1, i)
    MsgBox myfolder

Sub Sample()
    Dim valFile As Variant
    Dim i     As Integer
    valFile = Application.GetOpenFilename _
        ("Excelファイル (*.xls), *.xls", , , , True)
    If IsArray(valFile) Then
        For i = 1 To UBound(valFile)
            Debug.Print i & ":", valFile(i)
        Next i
    Else
        Debug.Print valFile
    End If
End Sub

ファイルサーチ

Sub Sample()
Dim strDir As String
Dim i As Long
Dim file(1000) As String
Dim lonCnt As Long
Const strFile = "*件数データ*.CSV"
strDir = "d:\down\"
With Application.FileSearch
    .NewSearch
    .LookIn = strDir
    .Filename = strFile
    If .Execute() > 0 Then
        For i = 1 To .FoundFiles.Count
            file(i) = .FoundFiles(i)
        Next i
    End If
    lonCnt = .FoundFiles.Count
End With
MsgBox lonCnt
End Sub

日付

'月末日取得
'datedat:yyyy/mm/dd
'dateflg:0当月末,-1先月末,1来月末
Public Function gmatsu(datedat As Date, dateflg As Integer) As String
Dim ansdate As Date
ansdate = DateSerial(Year(datedat), Month(datedat) + dateflg + 1, "01")
ansdate = ansdate - 1
gmatsu = Format$(ansdate, "yyyy/mm/dd")
End Function

'マイナス１ヶ月
Format(DateSerial(Year(Date), Month(Date) - 1, 1), "YYYYMM")

'当月末
Dim dDateI As Date
Dim dDateO As Date
dDateI = CDate("2012/09/20")
dDateO = DateSerial(Year(dDateI), Month(dDateI) + 1, 0)
MsgBox dDateO

コンボボックス

'初期処理
Private Sub UserForm_Initialize()
    For i = 2 To Evaluate("[xxx.XLS]Sheet2!f2").Value + 1
        ComboBox1.AddItem Evaluate("[xxx.XLS]Sheet2!a" & i).Value & " " &
Evaluate("[xxx.XLS]Sheet2!c" & i).Value
    Next i
    ComboBox1.Text = ComboBox1.List(0)
End Sub
'特定ブック処理
For i = 3 To Evaluate("[xxx.XLS]Sheet2!f2").Value + 1
    If Left(ComboBox1.List(ComboBox1.ListIndex), 4) =
Trim(Evaluate("[xxx.XLS]Sheet2!a" & i).Value) Then
        If filechk(Evaluate("[xxx.XLS]Sheet2!d" & i).Value) = True Then
            If fileopchk(filename) = False Then
                Workbooks.Open filename:="x:\xxx\xx\xxx\" & filename,
ReadOnly:=True
                outkbn = "1"
            Else
                msg = filename & "は既に開いています。"
                Style = vbOKOnly + vbInformation + vbDefaultButton1
                Response = MsgBox(msg, Style, Title, help, Ctxt)
            End If
        End If
    End If
Next i

リストボックス

'初期処理
Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 1
For i = 0 To 35
WA(i) = Evaluate("[xxx.xls]sheet2!a" & i + 1).Value
Next i
ListBox1.List() = WA
'Worksheets("SHEET1").Activate
TextBox3.Text = Evaluate("[BMEUC.xls]sheet2!a1").Value
End Sub

'列選択
Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer,
ByVal X As Single, ByVal Y As Single)
Worksheets("SHEET2").Activate
For i = 0 To 35
WA(i) = ""
WB(i) = ""
WC(i) = ""
Next i
j = 0
For i = 0 To 35
If ListBox1.Selected(i) = True Then
WA(j) = Worksheets("sheet2").Cells(i + 1, 1).Value
WB(j) = Worksheets("sheet2").Cells(i + 1, 2).Value
WC(j) = Worksheets("sheet2").Cells(i + 1, 3).Value
j = j + 1
End If
Next i
TextBox1.Text = j '列使用個数セット
End Sub

切り取りモード、またはコピーモードの状態を示す値を設定します

Application.CutCopyMode = False
使用できる値は、True、False、または次に示す XLCutCopyMode の定数のいずれかです。
値の取得および設定が可能です。長整数型 (Long) の値を使用します。

エラー処理

Dim i As Long
'On error resume next しているので、エラーがおきてもエラーをトラップ可能
On Error GoTo ErrHandler
i = "a"
If Err.Number <> 0 Then
End If
ExitSub:
Exit Sub
ErrHandler:
'Resume Next
MsgBox ("Error No =" & Err.Number & vbCr & "Error Msg=" & Err.Description)
Resume ExitSub

ブックを開いているか確認

Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name = filename Then
            MsgBox "開いています"
            Exit For
        End If
    Next wb

Dim i As Integer
    For i = 1 To Workbooks.Count
        If Windows(i).Caption = filename Then
            MsgBox "開いています"
            Exit For
        End If
    Next

ブック作成

Workbooks.Add
wbook = ActiveWorkbook.Name
Workbooks(wbook).Activate

マクロでマクロ起動

Workbooks.Open filename:="C:\xxx.XLS"
Application.Run Macro:="xxx.XLS!AUTO_OPEN"

全角スペースを半角スペースに

Replace(myStrings, Chr(-32448), Chr(32))　参考：cha(45) ハイフン

シート数

Worksheets.Count

アクティブシート名

ActiveSheet.Name

アクティブシート

Worksheets("SHEET1").Activate

検索

Private Sub CommandButton5_Click()
MsgBox findrtn("チェックシート.xls", "aite", "b", "c", "NQ5")
End Sub

Function findrtn(strBook As String, strSheet As String, strRange1 As String,
strRange2 As String, strCode As String) As String
Dim myCell As range
Dim firstAddress As String
findrtn = "?"
Workbooks(strBook).Activate
i = Worksheets(strSheet).range(strRange1 & "1").CurrentRegion.Rows.Count
With Worksheets(strSheet).range(strRange1 & "1:" & strRange1 & i)
Set myCell = .Find(strCode, MatchCase:=True, matchbyte:=True)
If Not myCell Is Nothing Then
firstAddress = myCell.Address
Do
'MsgBox Evaluate("[" & strBook & "]" & strSheet & "!" & _
strRange1 & myCell.Row).Value & " " & myCell.Address
If Trim(Evaluate("[" & strBook & "]" & strSheet & "!" & _
strRange1 & myCell.Row).Value) = strCode Then
findrtn = Evaluate("[" & strBook & "]" & strSheet & _
"!" & strRange2 & myCell.Row).Value
Exit Do
End If
Set myCell = .FindNext(myCell)
'MsgBox myCell.Address
'range(myCell.Address).Activate
Loop While Not myCell Is Nothing And myCell.Address <> firstAddress
End If
Set myCell = Nothing
End With
End Function
-----------------------------------------------------------------------
Dim myCell As Range
Dim myPosition As String
    Workbooks("チェックシート.xls").Activate
    i = Worksheets("aite").Range("B1").CurrentRegion.Rows.Count
    With Worksheets("aite").Range("b1:b" & i)
        Set myCell = .Find("NQ5D", MatchCase:=True, matchbyte:=True)
        If Not myCell Is Nothing Then
            MsgBox myCell.Address
            myPosition = myCell.Address
            Range(myPosition).Activate
        End If
        Set myCell = Nothing
    End With

四捨五入

Private Function dRound(tempValue As String, s As Integer) As Currency
Dim t As Integer
Dim X As Currency
X = tempValue
t = 10 ^ Abs(s)
If s > 0 Then
dRound = Int(X * t + 0.5) / t
Else
dRound = Int(X / t + 0.5) * t
End If
End Function

dRound(＜数値＞,＜桁数＞）
機能：＜数値＞を四捨五入して指定した＜桁数＞にします。

＜桁数＞に 0 を指定すると、＜数値＞はもっとも近い整数へ四捨五入されます。
例： dRound (2.149, 0) = 2 ------ 小数点第 1 位以下で四捨五入し、整数にします。

＜桁数＞に正の数を指定すると、＜数値＞は小数点以下で四捨五入されます。
例： dRound (2.149, 1) = 2.1 ---- 小数点第 2 位以下で四捨五入し、小数点
第 1 位迄の数値にします。
dRound (2.149, 2) = 2.15 --- 小数点第 3 位以下で四捨五入し、小数点
第 2 位迄の数値にします。

＜桁数＞に負の数を指定すると、＜数値＞は整数部分で四捨五入されます。
例： dRound (152.03, -1) = 150 -- 1 の位以下を四捨五入します。
dRound (152.03, -2) = 200 -- 10 の位以下を四捨五入します。
-----------------------------------------------------------------------
Excel 2000 の VBA には Round 関数が追加されました。VBA の Round 関数は、
Excel 2000 のワークシート関数 Round と異なる結果となる場合があります。

Excel 2000 のワークシート関数 Round は、"算術型" の丸め処理を行います。
この "算術型" 丸め処理では ".5" は常に切り上げられます。

これに対して VBA の Round 関数は "銀行型" の丸め処理を行います。
"銀行型" の丸め処理の場合は ".5" は、結果が偶数になるように丸め処理が行れ、
切り上げられることも、切り捨てられることもあります。
x = Application.WorksheetFunction.Round(y ,0)　←VBAでExcel関数を利用

カーソル

Application.Cursor = xlIBeam
xlDefault 標準のポインタ
xlWait 砂時計型ポインタ
xlNorthwestArrow 矢印型ポインタ
xlIBeam I 字型ポインタ

置き換え

Cells(1, 1).Replace What:="(", Replacement:="-"

置き換え

Replace(RTrim(wrow), "/", "-")　スラッシュをハイフンへ

Columnsの利用

With Worksheets(1)
.Cells(1, 2) = "AAAAAAAAAAAAAA"
.Columns(1).Select
Selection.NumberFormat = "@"
.Columns("A:C").Select
.Columns("A:C").EntireColumn.AutoFit
.Cells(1, 1).Select
End With

アクティブセルを取得する

MsgBox ActiveCell.Value
MsgBox ActiveCell.Row
MsgBox ActiveCell.Column

ワークシートのイベントを取得する

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Rows.Count > 1 Then
Exit Sub
End If
If Target.Columns.Count > 1 Then
Exit Sub
End If
MsgBox Target.Rows.Count
MsgBox Target.Row
MsgBox Target.Columns.Count
MsgBox Target.Column
MsgBox Target.Value
Application.EnableEvents = False
Cells(Target.Row + 1, Target.Column) = Target.Value
Application.EnableEvents = True
End Sub
'Activate ワークシートアクティブ
'SheetActivate ワークシートアクティブ

'SheetBeforeDoubleClick ワークシートダブルクリック
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Cancel = True 'Excel既定のダブルクリック操作をキャンセル
End Sub

'SheetBeforeRightClick ワークシート右クリック
'SheetCalculate ワークシート再計算
'SheetChange セルの変更
'SheetDeactivate ワークシート非アクティブ
'SheetFollowHyperlink ワークシートのハイパーリンクをクリック
'SheetSelectionChange 選択範囲を変更

ＥＸＣＥＬの終了

ThisWorkbook.Save 'ブック保存
Application.Quit 'EXCEL終了

プロシージャを一時停止させる方法

'プロシージャ名: PartOne -実行するプロシージャ(セル選択前の処理)
Sub PartOne()
'CommandBars("Pause").Delete
MsgBox "罫線を引きたいセルを選択してください。" & Chr(13) & _
"セル選択後、継続ボタンを押してください。"
'ツールバー作成プロシージャの呼び出し
CreatePauseToolbar
End Sub
'プロシージャ名: CreatePauseToolbar -ツールバーを作成するプロシージャ
Sub CreatePauseToolbar()
Dim NewBar As Object
'ツールバーの作成
Set NewBar = CommandBars.Add
With NewBar
.Name = "Pause"
.Visible = True
'ツールバーにボタンの追加
.Controls.Add Type:=msoControlButton
With .Controls(1)
.Style = msoButtonCaption
.Caption = "継続"
'プロシージャの登録
.OnAction = "PartTwo"
End With
End With
End Sub
'プロシージャ名: PartTwo -ツールボタンに登録するプロシージャ
Sub PartTwo()
'選択されているセルに罫線を引く
Selection.BorderAround Weight:=xlThick
'ツールバーの削除
CommandBars("Pause").Delete
End Sub

アクティブになっているブックに含まれるすべてのシート名をメッセージボックスに表示する

Dim mySheet As Object
For Each mySheet In ActiveWorkbook.Sheets
MsgBox mySheet.Name
Next mySheet

現在開かれているすべてのブックのファイル名をワークシートへセットする

Dim myBook As Object
Dim i As Long
i = 1
For Each myBook In Workbooks
Worksheets("Sheet1").Cells(i, 1).Value = myBook.Name
i = i + 1
Next myBook

Visual Basic でワークシート関数を使用する

MsgBox Application.WorksheetFunction.Find(".", "123.456", 1)
MsgBox Application.WorksheetFunction.Round(12.5, 0)

VBA の Round とワークシート関数 Round の違い

Excel 2000 のワークシート関数 Round は、"算術型" の丸め処理を行います。
この "算術型" 丸め処理では ".5" は常に切り上げられます。
これに対して VBA の Round 関数は "銀行型" の丸め処理を行います。
"銀行型" の丸め処理の場合は ".5" は、結果が偶数になるように丸め処理が行われ、
切り上げられることも、切り捨てられることもあります。
VBA と Excel 2000 の Round 関数の違いは、以下の表のようになります。

数値	VBA	Excel2000
1.5	2	2
2.5	2	3
3.5	4	4
4.5	4	5
5.5	6	6
6.5	6	7

入力したセルにその値を用いた計算結果を返す方法

次のサンプルは、Sheet1 のセルに入力された数値の倍の値を、
数値が入力されたセルに表示しています。

以下のコードは標準モジュールに入力します:
Public flg As Integer

以下のコードは Sheet1 のコードとして入力します:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Target.Offset(1, 0).Activate
flg = 1
MsgBox "このワークシートは変更されました。変更されたセルは、" _
& Target.Address & " です。"
Target.Font.ColorIndex = 5
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If flg = 1 Then
Target.Offset(-1, 0).Value = Target.Offset(-1, 0).Value * 2
flg = 0
End If
End Sub

次のサンプルは、Sheet1 のセルに数値を入力すると既に入力されていた
数値を足した値をセルに表示します。

以下のコードは標準モジュールに入力します:
Public flg As Integer

以下のコードは Sheet1 のコードとして入力します:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Target.Offset(1, 0).Activate
flg = 1
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If flg = 1 Then
Target.Offset(-1, 0).Value = Target.Offset(-1, 0).Value + _
Worksheets("Sheet2").Range(Target.Offset(-1, 0).Address)
Worksheets("Sheet2").Range(Target.Offset(-1, 0).Address).Value = _
Target.Offset(-1, 0).Value
flg = 0
End If
End Sub

ハイパーリンク

Sub Hyper()
'urlリンク
Dim objHyper As Object
With Worksheets(1)
Set objHyper = _
.Hyperlinks.Add(Anchor:=.Range("A1"), _
Address:="http://www.eonet.ne.jp/~aki/", ScreenTip:="ak09", TextToDisplay:= _
"http://www.eonet.ne.jp/~aki/")
End With
Set objHyper = Nothing
End Sub
Sub Hyper1()
'fileリンク
Dim objHyper As Object
With Worksheets(1)
Set objHyper = _
.Hyperlinks.Add(Anchor:=.Range("A2"), _
Address:="\\xxxxx\xxxxx\temp\a.txt", ScreenTip:="text")
objHyper.CreateNewDocument _
Filename:="\\xxxxx\xxxxx\temp\a.txt", _
EditNow:=True, Overwrite:=True
End With
Set objHyper = Nothing
End Sub

Sub Macro1()
Dim i As Long
i = 2
With Worksheets("一覧")
Do Until .Cells(i, 4).Value = ""
Cells(i, 4).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & .Cells(i, 4).Value & "'!A1", TextToDisplay:=Cells(i, 4).Value
i = i + 1
Loop
End With
End Sub

シート保護解除と保護

ActiveSheet.Unprotect
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

ＲａｎｇｅとＣｅｌｌｓの違い

Worksheets("Sheet1").Range("A1").Value = "1,1"
Worksheets("Sheet1").Range("A2").Value = "1,2"
Worksheets("Sheet1").Cells(1, 1).Value = "A1"
Worksheets("Sheet1").Cells(2, 1).Value = "A2"

Cells プロパティ
1 つのセルを取得するには、Cells(row, column) プロパティを使用します。
引数 row には、行のインデックスを指定します。引数 column には、
列のインデックスを指定します。

Cells プロパティで引数の数値を変化させる代わりに、
Visual Basic の文字列関数を使って A1 形式の参照文字列を変化させることもできますが、
Cells(1, 1) という記述の方が簡単であり、効率的なプログラミングの方法です。

セル範囲の一部を取得するには、expression.Cells(row, column) を使用します。
expression には、Range オブジェクトを表すオブジェクト式を指定します。
セル範囲の左上端を基準にして、引数 row と引数 column を指定します。
次の使用例は、セル C5 に数式を設定します。
Worksheets(1).Range("c5:c10").Cells(1, 1).Formula = "=rand()"

Range プロパティ
1 つのセルまたはセル範囲を表す Range オブジェクトを取得するには、
Range(arg) プロパティを使用します。
引数 arg には、範囲の名前を指定します。

次の使用例は、Criteria という名前のセル範囲の内容を消去します。
Worksheets(1).Range("criteria").ClearContents
セル範囲の参照を引数に指定する場合、参照は A1 形式で指定します。
R1C1 形式は使用できません。

セルの入力規則を設定

'With Range("E5").Validation
With Cells(1, 3).Validation
.Add Type:=xlValidateWholeNumber, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="5", Formula2:="10"
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = "5 10 "
.ErrorMessage = " 5 10 "
.IMEMode = xlIMEModeAlpha
End With

文字置き換え

Sub ReplaceNullChar(Str As String)
Dim i As Long

For i = 1 To Len(Str)
If Mid$(Str, i, 1) = Chr(0) Then
Mid$(Str, i, 1) = " "
End If
Next i
End Sub

コンボボックス

Sub EXEXEL_CBO()
'コンボボックス
MsgBox Worksheets("Sheet1").DropDowns("CboList").ListIndex '選択されている場所
MsgBox Worksheets("Sheet1").DropDowns("CboList").Value '選択されている場所
'選択されている値
MsgBox Worksheets("Sheet1").DropDowns("CboList").List(Worksheets("Sheet1").DropDowns("CboList").Value)
MsgBox Worksheets("Sheet1").DropDowns("CboList").ListCount '選択可能最大件数
MsgBox Worksheets("Sheet1").DropDowns("CboList").LinkedCell 'リンクセル
MsgBox Worksheets("Sheet1").DropDowns("CboList").Name 'コントロール名
MsgBox Worksheets("Sheet1").DropDowns("CboList").DropDownLines '表示リスト行
End Sub

ファイル検索

' RootPath : 検索を開始する基準のディレクトリ
' InputPathName : 検索するファイル名
' OutputPathBuffer : 見つかったファイル名を格納するバッファ。
' 戻り値 : 見つかると0以外を返す。
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
(ByVal RootPath As String, _
ByVal InputPathName As String, _
ByVal OutputPathBuffer As String) As Long

Private Const MAX_PATH = 512
Private Const MAX_PATH_PLUS1 = MAX_PATH + 1
Private Sub Command1_Click()
Dim lngResult As Long
Dim strBuffer As String * MAX_PATH_PLUS1
lngResult = SearchTreeForFile("D:\", "readme.txt", strBuffer)
If (lngResult <> 0) Then
Debug.Print Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1)
End If
End Sub

新規シート追加

Set newSheet = Sheets.Add(after:=ActiveWorkbook.Sheets("Sheet1"),Type:=xlWorksheet)
Set newSheet = Nothing

隠しオブジェクト?

Worksheets("Sheet1").DropDowns("LIST").Value
Worksheets("Sheet1").DropDowns("LIST").List(Worksheets("Sheet1").DropDowns("LIST").Value)
Worksheets("Sheet1").CheckBoxes("CHEK").Value
DialogSheets("DIALOG1").DropDowns("LIST").Value
DialogSheets("DIALOG1").EditBoxes("TEXT").Text

文字列をすべて大文字に変換して返す

Dim LowerCase, UpperCase
LowerCase = "Hello World 1234" ' 変換対象の文字列を定義します。
UpperCase = UCase(LowerCase) ' "HELLO WORLD 1234" を返します。

文字列を検索(完全検索)

Sub test()
MsgBox Find_Whole("島根県")
End Sub

Function Find_Whole(str As String) As Long
Dim obj As Object
    Find_Whole = 0
    With Worksheets(1).Range("A:A")
        Set obj = .Find(What:=str, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByColumns, MatchByte:=False)
        If Not obj Is Nothing Then
            MsgBox obj.Address
            Find_Whole = CInt(Mid(obj.Address, InStr(3, obj.Address, "$") + 1))
        End If
    End With
    Set obj = Nothing
End Function

Function getFind(strItem As String, sys As String) As Long
Dim obj As Object
Dim rc As String
    getFind = 0
    If sys = "XX" Then
        rc = "B:B"
    ElseIf sys = "XX" Then
        rc = "C:C"
    ElseIf sys = "XX" Then
        rc = "A:A"
    Else
        MSGBOX= "ERROR 処理不能です。"
        Exit Function
    End If

    getFind = 0
    With Worksheets(wsheets).Columns(rc)
        Set obj = .Find(What:=strItem, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByColumns, MatchByte:=False)
        If Not obj Is Nothing Then
            getFind = CInt(Mid(obj.Address, InStr(3, obj.Address, "$") + 1))
        End If
    End With
    Set obj = Nothing

End Function

Findメッソドの引数
　　(１)What := "鈴*"　　　　　　　　　　'検索するデータ、Variant型、ワイルドカード文字列を使用できます。
　　　'以降は、省略できます。
　　(２)After := Range("$C$12")　　　'検索を開始するRangeオブジェクト
　　(３)LookIn := xlValues　　　　　　'検索対象、xlValues：文字や数値、xlFormulas：数式、xlNotes：メモ
　　(４)LookAt := xlWhole　　　　　　'一部か全部か？、xlWhole：完全一致、xlPart：一部
　　(５)SearchOrder := xlByRows '検索方向、xlByRows：行方向を先に検索、xlByColumns：列方向を先に検索
　　(６)SearchDirecton := xlNext　'次か前か、xlNext：次を検索（規定値）、xlPrevious：前を検索
　　(７)MatchCase := FALSE　　　'大文字小文字の区別、FASLE：区別しない（規定値)、TRUE：区別する
　　(８)MatchByte := Ture '半角・全角の区別、Ture：区別する、False：しない。規定値は、前回の値。
（注意：引数 LookIn、LookAt、SearchOrder、および MatchByte の設定は、このメソッドが使われるたびに保存されます。）

文字列を検索(部分検索)

Function getMinato1(strItem As String) As String
    Dim strfirstAdd As String
    Dim ranc As Range
    Dim intRow As Integer
    Dim i As Long

    With Worksheets("sheet1").Columns("A:A")
        Set ranc = .Find(strItem)
        If Not ranc Is Nothing Then
            strfirstAdd = ranc.Address
            i = InStr(3, strfirstAdd, "$")
            intRow = CInt(Mid(strfirstAdd, i + 1))
        Else
            intRow = 0
        End If
    End With
    If intRow = 0 Then
        getMinato1 = ""
    Else
        getMinato1 = "ok"
    End If
End Function

Book4.xls のブックをアクティブにする

Workbooks("BOOK4.XLS").Activate
Windows("BOOK4.XLS").Activate

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

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

？？？

SUB

？？？

SUB

？？？

SUB

サ　ン　プ　ル

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