項目

新規シートにcsvファイルを文字列で読込む

内容説明

csvファイルの値が 0001,1.000 等であるときに見た目の通りにシートに読み込むkCsvReadS関数を示します。アクティグブックの新規シートに読み込むように設定しています。

'kCsvReadS関数 新規シートにcsvファイルを文字列で読込む
'引数  fname：読み込むcsvファイル名
'戻り値 0：成功 1:ファイルが在りません
Function kCsvReadS&(fname$)
  Dim txt$, ii%, ar(1 To 256), wb As Object
  If Dir(fname) = "" Then kCsvReadS = 1: Exit Function
  Set wb = ActiveWorkbook
  Application.ScreenUpdating = False
  For ii = 1 To 256: ar(ii) = Array(ii, 2): Next
  If Not InStr(1, Right(fname, 4), ".txt", vbTextCompare) Then _
    txt = fname & ".txt": Name fname As txt
  Workbooks.OpenText Filename:=txt, Comma:=True, FieldInfo:=ar
  ActiveSheet.Move After:=wb.Sheets(wb.Sheets.Count)
  If txt <> "" Then Name txt As fname
  Application.ScreenUpdating = True
End Function

'kCsvReadS関数の使用例
Sub test_kCsvReadS()
  Dim fname$, rt&
  fname = "C:\Documents and Settings\aaa\My Documents\bbb\ccc.csv" '読み込むcsvファイル
  rt = kCsvReadS(fname)
  If rt Then MsgBox "エラー " & rt
End Sub

項目

階層のあるフォルダを作成する

内容説明

階層のあるフォルダを作成するkMkDir関数を示します。

その1)簡易版

'kMkDir関数 階層のあるフォルダを作成
'引数 path：作成するフォルダ名　例："d:\eee\fff\ggg\hhh\"
'戻り値 0：成功 0以外：エラー番号
Function kMkDir&(ByVal path$)
  Dim ii&, atr&
  On Error Resume Next
  For ii = 1 To Len(path)
    If Mid(path, ii, 1) = "\" Then MkDir Left(path, ii - 1)
  Next
  MkDir path
  atr = GetAttr(path)
  If atr And vbDirectory Then Exit Function
  kMkDir = Err
End Function

'kMkDir関数の使用例
Sub test_kMakeDir()
  Dim ret&
  ret = kMkDir("d:\eee\fff\ggg\hhh\")
  If ret Then MsgBox Error(ret)
End Sub

その2)最新API版

'モジュ−ルレベル
Private Declare Function MakeSureDirectoryPathExists _
  Lib "imagehlp.dll" (ByVal lpPath As String) As Long

'MakeSureDirectoryPathExists関数の使用例
Sub test_MakeSureDirectoryPathExists()
  Dim ret&
  ret = MakeSureDirectoryPathExists("d:\eee\fff\ggg\hhh\")
  If ret = 0 Then MsgBox "error"
End Sub

項目

指定した範囲で重複なしで指定数の乱数を取得する

内容説明

乱数の取得方法です。
乱数は指定した下限値と上限値の範囲で、かつ指定数を重複なしで取得するマクロ例を示します。乱数は配列に取得してシートに一括書き込みをしています。

'重複なしで指定した範囲、数の乱数を取得する
Sub E00M068()
  Dim n1&, n2&, nn&, ii&, rr&, rd(), rg As Range, so As Boolean
  n1 = 10   '乱数の下限値
  n2 = 1000 '乱数の上限値
  nn = 100  '取得する乱数の数(重複なしで取得)
  so = True   'ソ−トする/しない
  Set rg = Range("b2") '取得した乱数を記入するセルのトップ
  If nn > n2 - n1 Then Exit Sub
  ReDim rd(1 To nn, 1 To 1)
  Randomize
  For ii = 1 To nn
    Do
      rr = Int((n2 - n1 + 1) * Rnd + n1)
    Loop While Not IsError(Application.Match(rr, rd, 0))
    rd(ii, 1) = rr
  Next
  With rg.Resize(nn)
    .Value = rd
    If so Then .Sort Key1:=rg
  End With
End Sub

項目

マクロでVBEプロジェクトの保護をする

内容説明

新たに作成したBookなどをプログラム(別Bookやアドインのマクロ)でプロジェクトの保護をしたい場合があります。
しかし、VBAにはプロジェクトの保護に関するプロパティは準備されていませんので一工夫必要です。
以下にVBAでプロジェクトを保護する VBAPjProtect関数 を示します。但しVBEで実行する事が必須です。

'kVBAPjProtect関数 VBAでプロジェクトを保護する(但しVBEで実行する事)
'引数 wb：プロジェクト保護するBook。保存済みであること
'     pw：パスワード(文字数は半角換算で1〜32文字まで)
'戻り値0：成功  -1:失敗
'      1：Bookは開かれていません
'      2：すでにプロジェクトの保護がされています
'      3：Bookは保存されていません。保存して実行して下さい
'      4：パスワード文字数が範囲外です
Function kVBAPjProtect&(ByVal wb As Workbook, ByVal pw$)
  On Error Resume Next
  With wb
    If Err Then kVBAPjProtect = 1: Exit Function
    On Error GoTo 0
    If .VBProject.Protection Then kVBAPjProtect = 2: Exit Function
    If .Name = .FullName Then kVBAPjProtect = 3: Exit Function
    If pw = "" Or LenB(StrConv(pw, vbFromUnicode)) > 32 Then kVBAPjProtect = 4: Exit Function
    Set Application.VBE.ActiveVBProject = .VBProject
    SendKeys "%TE^{TAB} {TAB}" & pw & "{TAB}" & pw & "{TAB}{ENTER}", True
    .Save
    Set wb = Workbooks.Open(.FullName)
  End With
  If wb.VBProject.Protection = False Then kVBAPjProtect = -1
End Function

'kVBAPjProtect関数の使用例
Sub test_kVBAPjProtect()
  Dim wb As Workbook, pw$, rt&
  Set wb = ActiveWorkbook
  pw = "aaa"     'パスワード
  rt = kVBAPjProtect(wb, pw)
  MsgBox IIf(rt = 0, "成功", "失敗")
End Sub

追記： 実用ツールとして、VBEに備わっていないVBAプロジェクトの保護等に関する支援コマンド をリリースしています。(フリーウェア)
こちらはVBEからもExcelからも実行する事が出来ます。

■エクセルVBA開発支援[kコマンド]
・Protect メソッド (VBAプロジェクトの保護)
・Unprotect メソッド (VBAプロジェクトの保護解除)
・Revision メソッド (改訂番号(Revision Number)を設定)
・Trap プロパティ (VBEエラートラップの種類を取得、設定)
・Tabinterval プロパティ (VBEのタブ間隔を取得、設定)
[kコマンド]のVectorページ

項目

アニメ−ションが出るプログレスダイアログを表示してファイルコピ−

内容説明

ファイルコピ−はFileCopyステートメント等で行う事が出来ますが、コピ−経過を表示したりキャンセルしたりする事は出来ません。
コピ−中にファイルが飛んでいくアニメ−ションのプログレスダイアログを表示する方法を示します。
これは[エクスプローラ] のコピ−と同じ仕様で、上書きの確認ダイアログが出たり、[キャンセル]する事が出来ます。
但し、ファイルサイズが小さいとプログレスダイアログは表示されません。これは仕様で、もし出たとしてもコピ−は瞬時に終わりますから当然です。
コピ−元のファイルはワイルドカ−ドが使えます。例えばコピ−元 "c:\dat\aaa\*.*" とした場合、フォルダ"c:\dat\aaa\"の全ファイル(フォルダを含まれる)がコピ−されます。
WindowsAPIのSHFileOperation関数を用います。

'モジュ−ルレベル
Type SHFILEOPSTRUCT
  hwnd As Long
  wFunc As Long
  pfrom As String
  pto As String
  fflags As Integer
  fAnyOperationsAborted As Long
  hNameMappings As Long
  lpszProgressTitle As String
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
  (lpFileOp As SHFILEOPSTRUCT) As Long
Const FO_COPY = &H2&
Const FOF_NOCONFIRMATION = &H10 '確認なし
Const FOF_NOERRORUI = &H400&    'エラーのダイアログを表示しない

'kFileOperationCp関数
'アニメ−ションが出るプログレスダイアログを表示してファイルコピ−
'引数 pfrom：コピー元
'     pto  ：コピー先
'     fflags：省略(アニメーション無し) true:アニメーション有り
'戻り値 0：成功　0以外：エラー
Function kFileOperationCp(pfrom$, pto$, Optional fflags As Boolean = False) As Long
  Dim fs As SHFILEOPSTRUCT
  fs.pfrom = pfrom 'コピー元のファイル名(ワイルドカード可)
  fs.pto = pto 'コピー先のフォルダ−
  fs.wFunc = FO_COPY
  fs.fflags = FOF_NOERRORUI Or IIf(fflags, 0, FOF_NOCONFIRMATION)
  kFileOperationCp = SHFileOperation(fs) 'rt=0 成功
End Function

'kFileOperationCp関数の使用例1 アニメ−ション及び確認有り
Sub test1_kFileOperationCp()
  Dim ret&
  ret = kFileOperationCp("c:\aaa", "c:\bbb", True)
  If ret Then MsgBox "Err=" & ret
End Sub

'kFileOperationCp関数の使用例2 アニメ−ション及び確認無し
Sub test2_kFileOperationCp()
  Dim ret&
  ret = kFileOperationCp("c:\aaa", "c:\bbb")
  If ret Then MsgBox "Err=" & ret
End Sub

項目

セル位置へCSVファイルを読込む

内容説明

CSVファイル(カンマ区切りのテキストファイル)をアクティブシ−トのセル位置へ読込む関数です。

'セル位置へcsvファイルを読込む
Sub kCsvRead()
  Const TIT = "CSVファイルを読込む"
  Dim csv$, rg As Range
  Set rg = Application.ActiveCell
  csv = Application.GetOpenFilename("CSV (カンマ区切り) (*.csv), *.csv", 1, TIT)
  If csv = "False" Then Exit Sub
  Application.ScreenUpdating = False
  With Workbooks.Open(csv)
    .ActiveSheet.UsedRange.Copy rg
    .Close
  End With
  Application.ScreenUpdating = True
End Sub

項目

文字のコ−ド変換

内容説明

文字をコ−ド(シフトJISコード)へ変換する関数をまとめてみました。
またUnicodeや暗号化について記述します。

'JISコード変換のtest
Sub a_E00M064()
  Dim ss$, jc%, sj%, hx$
  ss = "漢" 'シフトJISコード=&H8ABF
  
  '文字をシフトJISコードへ変換
  sj = Asc(ss)
  Debug.Print ss; "のシフトJISコード="; sj
  
  ' 文字をJISコードへ変換
  jc = Application.Evaluate("CODE(""" & ss & """)")
  Debug.Print ss; "のJISコード="; jc
  
  '10進数を16進数へ変換
  hx = "&H" & Hex(sj) '= Hex(jc)
  Debug.Print "シフトJISコード"; sj; "="; hx
  
  '16進数を10進数へ変換
  sj = Val(IIf(Left(hx, 1) = "&", "", "&H") & hx)
  Debug.Print "シフトJISコード"; hx; "="; sj
  
  'シフトJISコードを文字へ変換
  ss = Chr(sj)
  Debug.Print "シフトJISコード"; sj; "="; ss
  
  'シフトJISコードをJISコードへ変換
  jc = Application.Evaluate("CODE(""" & Chr(sj) & """)")
  Debug.Print "シフトJISコード"; sj; "=JISコード"; jc
  
  'JISコードを文字へ変換
  ss = Application.Evaluate("CHAR(" & jc & ")")
  Debug.Print "JISコード"; jc; "="; ss
  
  'JISコードをシフトJISコードへ変換
  sj = Asc(Application.Evaluate("CHAR(""" & jc & """)"))
  Debug.Print "JISコード"; jc; "=シフトJISコード"; sj
End Sub

追記1：Unicodeについて
Excel97からUnicode が採用されました。それにともないVBAの文字列を操作する関数が以前のバージョンと異なる結果を返す場合があります。
Unicodeは、これまでのANSI文字標準の256文字を超える文字数をサポートすることを目的として、国際標準化機構(ISO)が開発した文字標準です。
ANSI標準は共に8ビット(1 バイト)文字コードを使用しており、これが重複しない文字数を256文字に制限しています。これに対してUnicodeは16ビット(2バイト)コードを使用するため、65,536文字空間を実現し、現在は約34,000文字が割り当てられています。これは、現在世界中で使用されているすべての文字、象形文字など各種の古代言語、及び区切り記号、数学記号などが含まれています。

Excel97以降と以前のバージョンのVBAで結果の異なる可能性のある関数,ステートメントは次のものがあります。
Asc関数、Chr関数、InputB関数、InstrB関数、LeftB関数、LenB関数、RightB関数、MidB関数、及びこれら関数に対等するステートメント
Excel97以降のVBAで ANSI文字列の操作をおこなう場合には、StrConv関数を使用してUnicode形式とANSI 形式間の文字列変換処理をおこなう必要があります。

  'ANSI形式へ変換 引数vbFromUnicodeを指定してUnicode文字列からANSI文字列へ変換
  ss = StrConv("ABC あいう ", vbFromUnicode)
  'Unicode形式へ戻す 引数vbUnicodeを指定してANSI文字列からUnicode文字列へ変換
  ss = StrConv(MyStr, vbUnicode) 

'■全角・半角文字を区別して処理する例
  Dim ss$, ww&
  'ss = "aA1"
  ss = "aA1漢字"
  '半角は1文字全角は2文字として数える(バイト数)
  Debug.Print LenB(StrConv(ss, vbFromUnicode))
  '全角文字が含まれているか
  ww = LenB(StrConv(ss, vbFromUnicode)) - Len(ss)
  If ww = 0 Then
    Debug.Print "全角文字は含まれていません"
  Else
    Debug.Print "全角文字は含まれています 全角="; ww
  End If

'■文字列の左端から指定したバイト数の文字数の文字列を返す
Unicodeと全角の半分(1バイト)を切り捨てる処理等で複雑なコードになりますがワークシートLEFTB関数を用いると簡単です。
'kLeftB関数
'文字列の左端から指定したバイト数分の文字列を返します
'注) 全角の半分(1バイト)が残った場合半角スペースに置き換えます
'引数 str：文字列
'     length：取り出すバイト数(半角換算の文字数)
Function kLeftB(ByVal str As String, ByVal length As Long) As String
  kLeftB = Evaluate("LEFTB(""" & str & """," & length & ")")
End Function

Sub test_kLeftB() 'kLeftB関数の使用例
  Dim s1$, s2$, ll&
  s1 = "AAA全角文字"
  ll = 8 '左端から8バイトを取得
  s2 = kLeftB(s1, ll)
  Debug.Print s2
End Sub

システムの既定のコードページ内の文字コードを取得するにはAsc 関数を使用します。
Unicodeを取得するにはAscW 関数を使用します。
  Asc関数  ：システム既定の文字コードの取得 
  AscW 関数：Unicodeの取得 

システムの既定のコードページ内の文字コードから文字を取得するにはChr関数を使用します。
Unicodeから文字を取得するにはChrW 関数を使用します。
  Chr関数 ：システム既定の文字コードから文字を取得 
  ChrW関数：Unicodeから文字を取得 

Excel97以降のVBAは、新しいデータ型としてバイト型(Byte)が追加されています。バイナリ データを操作する際に文字列変数を使用すると入出力時に ANSI- Unicode変換がおこなわれてバイナリ データが変更されてしまいます。バイナリデータを扱う場合はバイト型の変数を利用します。

  Dim bd () As Byte
  bd = " 文字列 "                         ' Unicode形式で格納される
  bd = StrConv (" 文字列 ", vbFromUnicode)' ANSI形式で格納される 
  bd = InputB (10, #1)                    ' バイナリデータが格納される
  MsgBox bd (5)                           ' 配列としてデータを操作可能

追記2：簡易暗号化
VBAで暗号化ロジックを記述する場合はVBAのセキュリティを考えると厳密にしても意味がないと思われるので簡易的な方法を示します。 基本的なビットシフトして文字の順序を逆転する方法とXor演算による共通鍵方式を示します。

'■ビットシフトして文字の順序を逆転する方法
'kEasyEncrypt関数 文字列の簡易暗号化
'引数 Source:暗号化する文字列(全角文字可)
'戻り値 暗号化した文字列
Function kEasyEncrypt(ByVal Source As String) As String
  Dim bb() As Byte, buf() As Byte, ii&, ll&
  bb = Source: buf = bb: ll = UBound(bb)
  For ii = 0 To ll
    buf(ii) = (271 + ii - bb(ll - ii)) And 255
  Next
  kEasyEncrypt = buf
End Function

'kEasyDecrypt関数 復号(kEasyEncrypt関数で暗号化した文字列を元に戻す)
'引数 Source:kEasyEncrypt関数で暗号化した文字列
'戻り値 復号した文字列
Function kEasyDecrypt(ByVal Source As String) As String
  Dim bb() As Byte, buf() As Byte, ii&, ll&
  bb = Source: buf = bb: ll = UBound(bb)
  For ii = 0 To ll
    buf(ll - ii) = (271 + ii - bb(ii)) And 255
  Next
  kEasyDecrypt = buf
End Function

'kEasyEncrypt関数とkEasyDecrypt関数の使用例
Sub test_EasyEncrypt()
  Dim ss$
  ss = "qWeRt漢字ｶﾀｶﾅ!#$%&"
  ss = kEasyEncrypt(ss)
  Debug.Print "ss="; ss '暗号化した文字列
  ss = kEasyDecrypt(ss)
  Debug.Print "ss="; ss '復号した文字列
End Sub

'■Xor演算による共通鍵方式
'kKeyEncrypt関数 共通鍵方式の簡易暗号化及び復号化
'引数 Source:暗号化する文字列(全角文字可)又は暗号化した文字列
'     Key:暗号復号化に用いる共通鍵(文字列。全角文字可)
'戻り値 暗号化又は復元可した文字列
Function kKeyEncrypt(ByVal Source As String, ByVal Key As String) As String
  Dim bb() As Byte, kk() As Byte, ele, ii&
  bb = Source
  kk = Key
  For Each ele In kk
    For ii = 0 To UBound(bb)
      bb(ii) = bb(ii) Xor ele
    Next
  Next
  kKeyEncrypt = bb
End Function

'kKeyEncrypt関数の使用例
Sub test_KeyEncrypt()
  Dim ss$, b() As Byte, Key$
  ss = "qWeRt漢字ｶﾀｶﾅ!#$%&"
  Key = "pass"
  ss = kKeyEncrypt(ss, Key)
  Debug.Print "ss="; ss
  ss = kKeyEncrypt(ss, Key)
  Debug.Print "ss="; ss
End Sub

項目

ちょっと便利な関数アラカルト

内容説明

ちょっと便利な関数メモです。

SUBSTITUTEワークシート関数
書式
SUBSTITUTE(文字列, 検索文字列, 置換文字列, 置換対象)
文字列中の指定された文字を 他の文字に置き換えます。文字列中の任意の位置にある文字を他の文字に置き換えるにはREPLACE関数を用います。
Debug.Print Application.Substitute("a s d f g h j k", " ", "")

Replace関数
構文
Replace(expression, find, replace[, start[, count[, compare]]])
Excel2000からはSUBSTITUTEワークシート関数と同様機能のVBA関数であるReplace関数が使えます。
Debug.Print Replace("a s d f g h j k", " ", "")

Pictureプロパティ
オブジェクトの上に表示する ビットマップを設定します。
Image1.Picture = LoadPicture("c:\windows\花見.bmp")

MainWindowプロパティ
VBEメインウィンドウを表す Windowオブジェクトを返します。
' VBEウィンドウを表示/非表示
With Application.VBE.MainWindow
　.Visible = Not .Visible
End With
'VBEを起動
Application.VBE.MainWindow.Visible = True

Intersectメソッド
複数のセル範囲の 共有セル範囲を表すRange オブジェクトを返します。
Set is = Application.Intersect(Range("rg1"), Range("rg2"))
If is Is Nothing Then MsgBox "共通部分はありません"

Unionメソッド
複数のセル範囲を 集合させたセル範囲(Rangeオブジェクト)を返します。
Set urg = Application.Union(rg1, rg2)

Executeメソッド
コマンドバーコントロールに登録されているプロシージャを実行します。又はファイルの検索を開始します。
'CommandBarControlのID=115(下線) を実行
Application.CommandBars.FindControl(Id:=115).Execute

TypeName関数及びVarType関数
変数に関する 情報を提供する文字列型(String)の文字列を返します。
変数の内部処理形式を表す整数型(Integer)の値を返します。

EnableCancelKeyプロパティ
[Ctrl]+[Break]キー 又は[Esc]キーによる実行中のプロシージャに対するユーザーの割り込みの処理を指定します。

Resizeプロパティ
指定された範囲のサイズを変更します。 サイズが変更されたセル範囲(Rangeオブジェクト)を返します。
例： 表のタイトル行列を除いた部分を選択
　Set rg = ActiveCell.CurrentRegion
　rg.Offset(1, 1).Resize(rg.Rows.Count - 1, rg.Columns.Count-1).Select

項目

文字列であたえた数式の値を得る

内容説明

文字列の数式をオブジェクトまたは値に変換するにはEvaluateメソッドを用います。
これは結構重宝します。いくつかの使用例を示します。

'数式を計算
Debug.Print Application.Evaluate("=1+2+3+4+5+6+7+8+9+10")
'MAXワークシート関数を実行
Debug.Print Application.Evaluate("max(5,8,10)")
'INFOワークシート関数を実行
MsgBox "オペレーティングシステムのバージョン: " & Application.Evaluate("=INFO(""osversion"")")

Evaluateメソッドの代わりに角かっこを使う事が出来ます。

Debug.Print [=1+2+3+4+5+6+7+8+9+10]

kEvaluate関数
ユーザー関数にしてみました。セルの数式として組込み関数と同じように利用出来ます

'数式を計算するkEvaluate関数
'引数vv:計算式
'戻り値：計算結果
Function kEvaluate(vv)
　kEvaluate = Application.Evaluate("=" & vv)
　If TypeName(kEvaluate) = "Error" Then kEvaluate = "" 'Empty
End Function

kEvaluate関数の使用例
[B2] → 1+2+3
[D2] → =kEvaluate(B2)

項目

セルの文字を上付き又は下付き文字にする

内容説明

セルの文字を上付き又は下付き文字にするkScript関数を示します。

'kScript関数 セルの文字を上付き又は下付き文字にする
'引数
' rg: セル範囲
' ss: 上付き又は下付きにする文字(複数可)
' sup:True又は省略=上付き False=下付き
' siz:文字サイズ 省略可(既定値)
Sub kScript(rg As Range, ss$, Optional sup As Boolean = True, Optional siz! = 0)
  Dim ii&, rr As Range
  If TypeName(rg) <> "Range" Or ss = "" Then Exit Sub
  Application.ScreenUpdating = False
  For Each rr In rg
    For ii = 1 To Len(rr)
      If InStr(ss, Mid(rr, ii, 1)) Then
        With rr.Characters(Start:=ii, Length:=1).Font
          If siz Then .Size = siz
          .Superscript = sup
          .Subscript = Not sup
        End With
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub

'kScript関数の使用例
Sub test_kScript()
  kScript Selection, "23" '選択セルの文字2及び3を上付き文字にする
  kScript Range("b3:f20"), "AW", 0 '指定範囲セルの文字A及びWを下付き文字にする
End Sub

追記： 実用ツールとして[上付き][下付き]コマンドや[添え字]コマンド(化学式や単位記号等に自動対応)を実装した[k蘭]をリリースしています。
ぜひお試し下さい。
エクセル入力支援[k蘭]