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

データの最後

MsgBox Cells(Rows.Count, 1).End(xlUp).Row

サ　ン　プ　ル

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