Sub CallTest()
Debug.Print 最大公約数(24, 96)
End Sub
Function 最大公約数(ByVal M As Long, ByVal N As Long) As Long
If M <= 0 Or N <= 0 Then Exit Function
'M>=Nに調整
If M < N Then Swap M, N
Dim Q As Long, R As Long
Do
Q = M \ N
R = M Mod N
If R = 0 Then
最大公約数 = N
Exit Function
End If
M = N
N = R
Loop
End Function
Private Sub Swap(A As Long, B As Long)
Dim Tmp As Long
Tmp = A
A = B
B = Tmp
End Sub
Sub Sample()
Dim Fld As String
Dim Fname As String
Dim Wb As Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
Fld = .SelectedItems(1) & "\"
Else
'Debug.Print "キャンセルしました。"
Exit Sub
End If
End With
Fname = Dir(Fld & "*.xlsx")
Do Until Fname = ""
'Debug.Print Fld & Fname
Set Wb = Workbooks.Open(Fld & Fname)
'Wbに対する処理
Wb.Close
Fname = Dir()
Loop
End Sub
'テキストファイルへの出力
Sub PnsCallTest4()
'10億で190秒
Dim Pns As Variant
Dim T As Single
Dim N As Integer, i As Long
T = Timer
'素数配列の取得
Pns = PrimeNumbers(1 * 10 ^ 7)
Debug.Print Timer - T
N = FreeFile
'デスクトップのtest.txtへ
Open CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\test.txt" For Output As #N
For i = 1 To UBound(Pns)
Print #N, CStr(i); ","; CStr(Pns(i))
Next
Close #N
Debug.Print Timer - T
End Sub
'シートへの書き出し
Sub PnsCallTest3()
Dim Pns As Variant
Dim T As Single
T = Timer
'素数配列の取得
Pns = PrimeNumbers(82 * 10 ^ 4)
Debug.Print Timer - T
'配列をN行1列に変換してシートへ
If UBound(Pns) >= 0 Then
' 'アドインの素を参照設定している時 (シートの限界約1600万まで可能)
' Dim cFn As cFunction
' Set cFn = SourceOfAddin.GetClass.FunctionClass
' ActiveCell.Resize(UBound(Pns)).Value = cFn.Transpose2(Pns)
'ワークシート関数で縦横変換（およそ82万(65536個)まで可能）
ActiveCell.Resize(UBound(Pns)).Value = Application.WorksheetFunction.Transpose(Pns)
End If
End Sub
'素数配列(添え字１から)の取得
Private Function PrimeNumbers(ByVal N As Long) As Variant
'10^6で0.07秒、10^7で0.7秒、10^8で7.4秒、一ケタで約10倍の時間となる模様
Dim i As Long, j As Long
Dim Max As Long
Dim Flg() As Boolean 'FlagPrimeNumbers
Dim Pns() As Long 'PrimeNumbers
Dim C As Long
If N < 2 Then
PrimeNumbers = Array()
Exit Function
End If
'まず仮に全て素数であるとする
ReDim Flg(1 To N)
For i = 1 To N
Flg(i) = True
Next
'1は素数ではない
Flg(1) = False
'チェックする最大値
Max = Sqr(N)
For i = 2 To Max
'i番目が素数なら
If Flg(i) Then
'その倍数をふるい落とす
For j = i + i To N Step i
Flg(j) = False
Next
End If
Next
'素数の数を数える
C = 0
For i = 1 To N
If Flg(i) Then C = C + 1
Next
'素数を配列にセット
ReDim Pns(1 To C)
C = 0
For i = 1 To N
If Flg(i) Then
C = C + 1
Pns(C) = i
End If
Next
PrimeNumbers = Pns
End Function
※下記コードはシート内すべての図形が対象
Sub FitToCell()
Dim Shp As Shape
Dim X0 As Double, X1 As Double
For Each Shp In ActiveSheet.Shapes 'すべての図形が対象
X0 = NearX(Shp.TopLeftCell, Shp.Left)
X1 = NearX(Shp.BottomRightCell, Shp.Left + Shp.Width)
If X0 = X1 Then
Else
Shp.Left = X0
Shp.Width = X1 - X0
End If
Next
End Sub
Private Function NearX(R As Range, X As Double) As Double
Dim X0 As Double, X1 As Double
X0 = R.Left
X1 = X0 + R.Width
If X < X0 Then
NearX = X0
ElseIf X > X1 Then
NearX = X1
Else
If (X - X0) / (X1 - X0) < 0.5 Then
NearX = X0
Else
NearX = X1
End If
End If
End Function
CreateObject("WScript.Shell").CurrentDirectory =ネットワークパス
'WordVBA 検索の一例（文字検索、それを含む段落＋下2段落を選択）
Sub WordのFindメソッド()
Dim RR As Word.Range
Set RR = ActiveDocument.Content
'※Findメソッドを実行すると対象のRangeは見つけたものに置き換わる
With RR.Find
.ClearFormatting
.MatchFuzzy = True
.Text = "検索文字列"
If .Execute Then
'段落に拡張
RR.Expand wdParagraph
'さらに2段落下まで拡張
Set RR = ActiveDocument.Range(RR.Start, RR.Next(wdParagraph, 2).End)
Else
Set RR = Nothing
End If
End With
If Not RR Is Nothing Then
RR.Select
Else
MsgBox "NotFound", vbExclamation
End If
End Sub
Sub test()
MsgBox Color2RGB(ActiveCell.Interior.Color)
End Sub
'セルの塗りつぶし色をRGBに分解
Function Color2RGB(ColorNumber As Long) As String
Dim R As Long, G As Long, B As Long
R = ColorNumber Mod 256
G = ColorNumber \ 256 Mod 256
B = ColorNumber \ 256 \ 256 Mod 256
Color2RGB = CStr(R) & "," & CStr(G) & "," & CStr(B)
End Function
'===== UserForm1モジュール =====
Private Sub UserForm_Initialize()
LimitTime = Now + TimeSerial(0, 3, 0) '設定時間
CountDown
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
Application.OnTime NextTime, "CountDown", , False
End Sub
'=====標準モジュール =====
Option Explicit
Public LimitTime As Date
Public NextTime As Date
Sub Start()
UserForm1.Show vbModeless
End Sub
Sub CountDown()
NextTime = Now + TimeSerial(0, 0, 1)
UserForm1.Label1.Caption = Format$(LimitTime - Now, "nn:ss")
If Now >= LimitTime Then
MsgBox "時間です。", vbExclamation
Unload UserForm1
Else
Application.OnTime NextTime, "CountDown"
End If
End Sub
'※「アドインの素」への参照設定が必要です。
' http://hp.vector.co.jp/authors/VA033788/addinsample.html
' http://hp.vector.co.jp/authors/VA033788/softmenu.html#017
' https://www.vector.co.jp/soft/winnt/business/se503721.html
Sub CallSample()
Dim Fld As String
Fld = CreateObject("WScript.Shell").SpecialFolders("DeskTop")
Fld = Fld & "\test\test1\test2\test3\test4"
If MakeFolder2(Fld) Then MsgBox "ok"
End Sub
'多階層フォルダ作成
Function MakeFolder2(ByVal Fld As String) As Boolean
'作成成功or既存 True 失敗 False
Dim cGA As cGetAttr
Dim ErrMsg As String
Set cGA = SourceOfAddin.GetClass.GetAttrClass
MakeFolder2 = cGA.MakeDir(Fld, ErrMsg)
If ErrMsg <> "" Then
MsgBox ErrMsg, vbExclamation
End If
Set cGA = Nothing
End Function
Sub CallSample()
Dim Fld As String
Fld = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\test"
MakeFolder Fld
End Sub
'フォルダ作成（無い時に作成、既存の時は何もしない）
Sub MakeFolder(ByVal Fld As String)
Dim Res As VbFileAttribute
On Error Resume Next
Res = GetAttr(Fld) And vbDirectory
On Error GoTo 0
If Res <> vbDirectory Then
MkDir Fld
End If
End Sub
Sub test()
Dim VV As Variant
Dim V As Variant
VV = RangeToAry(Selection, Range("e3:e4"), Range("c18,d19,g4"))
For Each V In VV
Debug.Print V
Next
End Sub
'RangeのValueを一次元配列に変換
Function RangeToAry(Rng1 As Range, ParamArray RngOther()) As Variant
Dim RR As Range
Dim Ary() As Variant
Dim C As Long
Dim i As Long
RangeToArySub ToUsedRange(Rng1), Ary(), C
For i = LBound(RngOther) To UBound(RngOther)
RangeToArySub ToUsedRange(RngOther(i)), Ary(), C
Next
RangeToAry = Ary()
End Function
'行又は列全体の時は使用範囲内に絞る
Private Function ToUsedRange(ByVal RR As Range) As Range
If RR.Rows.Count = RR.Worksheet.Rows.Count Then
Set RR = Intersect(RR, RR.Worksheet.UsedRange)
End If
If RR.Columns.Count = RR.Worksheet.Columns.Count Then
Set RR = Intersect(RR, RR.Worksheet.UsedRange)
End If
Set ToUsedRange = RR
End Function
Private Sub RangeToArySub(ByVal Rng As Range, ByRef Ary() As Variant, ByRef C As Long)
Dim Are As Range
Dim VV As Variant
Dim V As Variant
Dim N As Long
For Each Are In Rng.Areas
N = Are.Cells.Count
ReDim Preserve Ary(1 To C + N)
If N = 1 Then
C = C + 1
Ary(C) = Are.Value
Else
VV = Are.Value
For Each V In VV
C = C + 1
Ary(C) = V
Next
End If
Next
End Sub
'※「アドインの素」への参照設定が必要です。
' http://hp.vector.co.jp/authors/VA033788/addinsample.html
' http://hp.vector.co.jp/authors/VA033788/softmenu.html#017
' https://www.vector.co.jp/soft/winnt/business/se503721.html
Sub ReNameFiles()
Dim cFL As cFileList2
Dim cFn As cFunction
Dim Fpaths As Variant
Dim C As Long, N As Variant
Dim fromPath As String
Dim toPath As String
Dim i As Long
Set cFL = SourceOfAddin.GetClass.FileList2Class
Set cFn = SourceOfAddin.GetClass.FunctionClass
'フルパスリスト取得
With cFL
.SearchPattern = "*.jpg" 'ファイルの検索パターン
.Execute .DeskTopPath & "\Data" '引数のパスに対して検索実行
Fpaths = .FullNames
C = .Count
End With
'桁数
N = Int(Log(C) / Log(10)) + 1
N = String$(N, "0")
'リネーム
For i = 0 To UBound(Fpaths)
fromPath = Fpaths(i)
toPath = Replace(fromPath, cFn.FileNameOnly(fromPath), Format$(i + 1, N))
Name fromPath As toPath
Next
Set cFL = Nothing
Set cFn = Nothing
End Sub
Sub test()
DrawLine Range("B2"), 0, 0, Range("H2"), 0, 0
DrawLine Range("C3"), 50, 50, Range("J3"), 50, 50
With DrawLine(Range("A5"), 0, 50, Range("G5"), 70, 50).Line
.ForeColor.RGB = vbBlack
.Weight = 3
.EndArrowheadStyle = msoArrowheadOpen
End With
End Sub
Sub test2()
DL2 "A1", "C5"
DL2 "C5", "D15"
DL2 "D15", "H3"
DL2 "H3", "A1"
End Sub
'セル中央に線を引く
Sub DL2(ByVal S As String, ByVal E As String)
DrawLine Range(S), 50, 50, Range(E), 50, 50
End Sub
'線引き（開始セル、そのX方向％、Y方向％、終了セル、そのX方向％、Y方向％）
Function DrawLine(ByVal rngS As Range, ByVal PsX As Single, ByVal PsY As Single _
, ByVal rngE As Range, ByVal PeX As Single, ByVal PeY As Single) As Shape
Dim X1 As Single, Y1 As Single
Dim X2 As Single, Y2 As Single
Dim W As Single, H As Single
With rngS
W = .Width: H = .Height
X1 = .Left + W * PsX / 100
Y1 = .Top + H * PsY / 100
End With
With rngE
W = .Width: H = .Height
X2 = .Left + W * PeX / 100
Y2 = .Top + H * PeY / 100
End With
Set DrawLine = rngS.Worksheet.Shapes.AddLine(X1, Y1, X2, Y2)
End Function
'確率乱数
Function Rand2() As Long
Static Flg As Boolean '初期化済みフラグ
Static Ratio As Variant
Dim i As Long
Dim Z As Double
Dim V As Single
Dim N As Long
If Not Flg Then
'比率
Ratio = Array(1, 1, 1, 1, 2, 2, 2, 2)
'合計
For i = LBound(Ratio) To UBound(Ratio)
Z = Z + Ratio(i)
Next
'比率計算
For i = LBound(Ratio) To UBound(Ratio)
Ratio(i) = Ratio(i) / Z
Next
'しきい値
For i = LBound(Ratio) + 1 To UBound(Ratio)
Ratio(i) = Ratio(i - 1) + Ratio(i)
Next
Randomize
Flg = True
End If
V = Rnd()
For i = LBound(Ratio) To UBound(Ratio)
If V < Ratio(i) Then
N = i - LBound(Ratio) + 1
Exit For
End If
Next
Rand2 = N
End Function
Sub CallSample()
Dim R As Range
Set R = Worksheets("Sheet2").Range("B2")
Set R = GetNextCell(R)
'確認
Application.Goto R
End Sub
'指定のトップセルからみて次の空セルを返す（シート最下行から上方を検索）
Function GetNextCell(ByVal rngTop As Range) As Range
Dim R As Range
Set R = rngTop.Cells(1)
Set R = R.EntireColumn
Set R = R.Cells(R.Cells.Count).End(xlUp)
If R.Row < rngTop.Row Then
Set R = rngTop.Cells(1)
End If
If Not IsEmpty(R.Value) Then
Set R = R.Offset(1)
End If
Set GetNextCell = R
End Function
'指定のトップセルからみて次の空セルを返す（シート最右列から左方向を検索）
Function GetNextCell2(ByVal rngTop As Range) As Range
Dim R As Range
Set R = rngTop.Cells(1)
Set R = R.EntireRow
Set R = R.Cells(R.Cells.Count).End(xlToLeft)
If R.Column < rngTop.Column Then
Set R = rngTop.Cells(1)
End If
If Not IsEmpty(R.Value) Then
Set R = R.Offset(, 1)
End If
Set GetNextCell2 = R
End Function
Sub CallSample()
Dim RR As Range
Set RR = Worksheets("Sheet2").Range("B2")
Set RR = GetColumn(RR)
'確認
Application.Goto RR
End Sub
'指定のトップセルから最下行までのセル範囲を返す（シート最下行から上方を検索）
Function GetColumn(ByVal rngTop As Range) As Range
Dim RR As Range
Set RR = rngTop.Cells(1)
Set RR = RR.EntireColumn
Set RR = RR.Cells(RR.Cells.Count).End(xlUp)
If RR.Row < rngTop.Row Then
Set RR = rngTop.Cells(1)
Else
Set RR = RR.Worksheet.Range(rngTop, RR)
End If
Set GetColumn = RR
End Function
'指定のトップセルから最右列までのセル範囲を返す（シート最右列から左方を検索）
Function GetRow(ByVal rngTop As Range) As Range
Dim RR As Range
Set RR = rngTop.Cells(1)
Set RR = RR.EntireRow
Set RR = RR.Cells(RR.Cells.Count).End(xlToLeft)
If RR.Column < rngTop.Column Then
Set RR = rngTop.Cells(1)
Else
Set RR = RR.Worksheet.Range(rngTop, RR)
End If
Set GetRow = RR
End Function
Sub Sample0()
Dim R As Range
Dim i As Long
Set R = Range("E4")
For i = 1 To 5
MsgBox R.Value
R.Value = NextNumber(R.Value)
Next
NextNumber ""
End Sub
'文字列＆数字列、の次の番号を返す
Private Function NextNumber(ByVal Num As String) As String
Static Reg As Object 'RegExp
Dim Mtc As Object ' Match
Dim sMtcs As Object ' SubMatches
Dim strS As String
Dim strN As String
Dim N As Long
If Num = "" Then
Set Reg = Nothing
Exit Function
End If
If Reg Is Nothing Then
Set Reg = CreateObject("VBScript.RegExp")
End If
With Reg
.Pattern = "(\D+)(\d+)"
Set Mtc = .Execute(Num)(0)
Set sMtcs = Mtc.SubMatches
strS = sMtcs(0)
strN = sMtcs(1)
N = CLng(strN) + 1
strS = strS & Format$(N, String$(Len(strN), "0"))
End With
NextNumber = strS
End Function
'※「アドインの素」への参照設定が必要です。
' http://hp.vector.co.jp/authors/VA033788/addinsample.html
' http://hp.vector.co.jp/authors/VA033788/softmenu.html#017
' https://www.vector.co.jp/soft/winnt/business/se503721.html
Sub CallSample()
Dim Fpath As String
Dim FList As Variant
'検索するフォルダ
Fpath = cFL2.MyDocumentsPath
'ファイルリスト取得
FList = GetFileList(Fpath)
If cFL2.Count = 0 Then
MsgBox "ファイルが見つかりません。", vbExclamation
Exit Sub
End If
'新規ワークシートに表示
With cFL2
Workbooks.Add.Worksheets(1).Range("A1").Resize(.Count) _
.Value = .Transpose2(.FullNames)
ActiveWorkbook.Saved = True
End With
End Sub
'サブフォルダを含むファイルリスト（フルパス）を取得
Private Function GetFileList(TopFolder As String) As Variant
With cFL2
.SearchPattern = "*.xls;*.xla;*.xlsx;*.xlsm" '複数指定可
.SearchSubFolders = True
.Execute TopFolder, SortBy:=msoSortByNone 'Sort指定は他にファイル名、フルパス、更新日付など
GetFileList = .FullNames 'ファイル名だけなら.Fnames
End With
End Function
'ファイルリスト取得クラス
Private Function cFL2() As cFileList2
Static cFL As cFileList2
If cFL Is Nothing Then
Set cFL = SourceOfAddin.GetClass.FileList2Class
End If
Set cFL2 = cFL
End Function
Sub LoadPictureLight()
Dim Fld As String
Dim Fname As String
Dim Fnames() As String
Dim Times() As Date
Dim Ndx As Variant
Dim C As Long
Dim i As Long
Dim rngD As Range
Dim Pic As Shape
If Not GetFolder(Fld) Then Exit Sub
Fld = Fld & "\"
Fname = Dir(Fld & "*.*")
Do Until Fname = ""
If IsTarget(Fname) Then
C = C + 1
ReDim Preserve Fnames(1 To C)
ReDim Preserve Times(1 To C)
Fnames(C) = Fname
Times(C) = FileDateTime(Fld & Fname)
End If
Fname = Dir()
Loop
If C = 0 Then
MsgBox "対象ファイルがありません。", vbExclamation
Exit Sub
End If
Ndx = MsCombSortI(Times)
'貼付け先の最初のセル
Set rngD = Range("A1")
For i = 1 To C
Fname = Fnames(Ndx(i))
Set Pic = ActiveSheet.Shapes.AddPicture(Fld & Fname, msoFalse, msoTrue, rngD.Left, rngD.Top, 0, 0)
Pic.ScaleWidth 1, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
Pic.ScaleHeight 1, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
Set rngD = Intersect(rngD.EntireColumn, Pic.BottomRightCell.EntireRow).Offset(2)
Next
End Sub
Private Function IsTarget(Fname As String) As Boolean
Dim Ext As String
Dim i As Long
i = InStrRev(Fname, ".")
If i >= 1 Then
Ext = Mid$(Fname, i + 1)
End If
Ext = LCase(Ext)
Select Case Ext
'画像ファイルの拡張子（小文字）
Case "jpg", "jpeg", "bmp", "gif", "png"
IsTarget = True
End Select
End Function
'処理対象フォルダ選択
Private Function GetFolder(Fld As String) As Boolean
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "処理対象フォルダを選択してください。"
If .Show Then
Fld = .SelectedItems(1)
GetFolder = True
Else
GetFolder = False
End If
End With
End Function
Private Function MsCombSortI(Ary As Variant) As Variant
'昇順インデックスを返す
'配列引数Aryは１次元限定
Dim Idx() As Long
Dim L As Long
Dim U As Long
Dim i As Long
Dim gap As Long
Dim Temp As Long
Dim F As Boolean
L = LBound(Ary)
U = UBound(Ary)
'インデックス初期設定
ReDim Idx(L To U)
For i = L To U
Idx(i) = i
Next
gap = U - L
F = True
'並べ替え
Do While gap > 1 Or F = True
gap = Int(gap / 1.3)
If gap = 9 Or gap = 10 Then
gap = 11
ElseIf gap < 1 Then
gap = 1
End If
F = False
For i = L To U - gap
If Ary(Idx(i)) > Ary(Idx(i + gap)) Then '降順時は <
Temp = Idx(i)
Idx(i) = Idx(i + gap)
Idx(i + gap) = Temp
F = True
ElseIf Ary(Idx(i)) = Ary(Idx(i + gap)) Then
If Idx(i) > Idx(i + gap) Then '昇順降順変更しても変更の必要なし
Temp = Idx(i)
Idx(i) = Idx(i + gap)
Idx(i + gap) = Temp
F = True
End If
End If
Next
Loop
MsCombSortI = Idx()
End Function
Sub PrintAutoFilter()
Dim rngAF As Range
Dim RR As Range
Dim R As Range
Dim VV As Variant
Dim V As Variant
Const KeyColumn As Long = 4 'キー列
If Not ActiveCell.Worksheet.AutoFilterMode Then Exit Sub
Set rngAF = ActiveCell.Worksheet.AutoFilter.Range
'オートフィルタのフィルタリセット
rngAF.Worksheet.AutoFilter.ShowAllData
'キー列データ
Set RR = rngAF.Columns(KeyColumn)
Set RR = Intersect(RR, RR.Offset(1))
VV = GetSummary(RR)
'印刷ループ
For Each V In VV
rngAF.AutoFilter KeyColumn, V
rngAF.PrintPreview
'rngAF.PrintOut '実際の印刷時にはこちらを有効にする
Next
'オートフィルタのフィルタリセット
rngAF.Worksheet.AutoFilter.ShowAllData
End Sub
'Rangeを受け、重複の無い一次元配列(添え字0ベース)を返す
Private Function GetSummary(RR As Range) As Variant
'返す配列の添え字下限は0
Dim R As Range
Dim Dic As Object
Dim K As Variant
Dim V As Variant
Set Dic = CreateObject("Scripting.Dictionary")
For Each R In RR.Cells
K = R.Value
If K <> "" Then
Dic(K) = Empty
End If
Next
V = Dic.keys
Set Dic = Nothing
GetSummary = V
End Function
activecell.Phonetic.Text ="エーエーエー"
activecell.Phonetic.Visible=true
activecell.Phonetics.Count
activecell.SetPhonetic
Sub test()
Dim Pho As Excel.Phonetics
For Each Pho In ActiveCell.Phonetics
Debug.Print Pho.Text, Pho.Start, Pho.Length
Next
End Sub
Sub test2()
Dim Phs As Phonetics
Dim Ph As Phonetics
Set Phs = ActiveCell.Phonetics
For Each Ph In Phs
With ActiveCell.Offset(2)
.Characters(Ph.Start, Ph.Length).PhoneticCharacters = Ph.Text
End With
Next
End Sub
Sub CallTest()
Dim Shps As ShapeRange
Dim Shp As Shape
Set Shps = GetShapes(Range("A1:H20"))
If Not Shps Is Nothing Then
For Each Shp In Shps
Debug.Print Shp.Name
Next
Else
Debug.Print "Not Found"
End If
End Sub
'セル範囲の中に左上が含まれている図形範囲を返す
Public Function GetShapes(Rng As Range, Optional PictureOnly As Boolean = False) As ShapeRange
Dim Ndx() As String
Dim C As Long
Dim Shp As Shape
C = 0
For Each Shp In Rng.Worksheet.Shapes
If Not Application.Intersect(Shp.TopLeftCell, Rng) Is Nothing Then
If PictureOnly Then
If Shp.Type = msoPicture Then
C = C + 1
ReDim Preserve Ndx(1 To C)
Ndx(C) = Shp.Name
End If
Else
C = C + 1
ReDim Preserve Ndx(1 To C)
Ndx(C) = Shp.Name
End If
End If
Next
If C >= 1 Then
Set GetShapes = Rng.Worksheet.Shapes.Range(Ndx)
Else
Set GetShapes = Nothing
End If
End Function
'===== ThisWorkbookモジュール =====
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'Sheet1でのみ動作させる
If Sh.Name <> "Sheet1" Then Exit Sub '<===適宜変更
'一セル以上の選択なら抜ける
If Target.Cells.Count >= 2 Then Exit Sub
'動作セル範囲
Dim Rng As Range
Set Rng = Target.Worksheet.Range("B3:H23") '<===適宜変更
'範囲外なら抜ける
If Intersect(Target, Rng) Is Nothing Then Exit Sub
'十字セレクト
Dim R As Range, C As Range
Set R = Target.EntireRow
Set C = Target.EntireColumn
Intersect(Union(R, C), Rng).Select
Target.Activate
End Sub
'===== ThisWorkbookモジュール =====
Option Explicit
'アプリケーションレベルのイベントで全ブックで使用可能にする
Private WithEvents myExl As Application
'このブックのプロジェクト名と同じ値を設定すること
Private Const myProjectName As String = "myPrj" '★重要
'機能を有効にするにはブックを開き直すかここを実行する
Private Sub Workbook_Open()
Set myExl = Application
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myExl = Nothing
End Sub
Private Sub myExl_SheetBeforeRightClick _
(ByVal Sh As Object, ByVal Target As Range _
, Cancel As Boolean)
'動作箇所の制限
If Target.Column <> 1 Then Exit Sub
Dim myBar As CommandBar
Dim myList As Variant
Dim V As Variant
'本来の右クリックを表示しない
Cancel = True
'設定するリストのデータ
myList = Array("Data1", "Data2", "Data3")
'一時的にポップアップを作成
Set myBar = Application.CommandBars.Add _
(Name:="Temp", Position:=msoBarPopup, temporary:=True)
'リストの設定
For Each V In myList
With myBar.Controls.Add(Type:=msoControlButton, temporary:=True)
.Caption = V
.OnAction = myProjectName & ".ThisWorkbook.選択"
End With
Next
'リスト表示
myBar.ShowPopup
'後始末
myBar.Delete
Set myBar = Nothing
End Sub
'リスト選択時に実際に動作するプロシージャ
Private Sub 選択()
Dim D As String
'クリックされたコントロールのCaption
D = Application.CommandBars.ActionControl.Caption
MsgBox D
End Sub
Sub Sample()
Dim RR As Range
Set RR = ActiveCell.Worksheet.AutoFilter.Range
Set RR = Intersect(RR.SpecialCells(xlCellTypeVisible), RR.Offset(1))
RR.Copy 貼り付け先セル
End Sub
'一覧表シートに各シートへのハイパーリンクリストを設定する（各シートからの「戻る」も）
Private Sub SetHyperlinks()
Dim wsMain As Worksheet
Dim Sht As Worksheet
Dim ShtNames() As String
Dim Na As String
Dim C As Long, i As Long
Dim R As Range
Const TopCellAddress As String = "B2"
Const adr一覧表に戻る As String = "H1"
Const MaxRow As Long = 10
Const RowStep As Long = 2
Const ColStep As Long = 2
Set wsMain = Worksheets(1) '一覧表シート
'既存リストクリア
wsMain.UsedRange.Clear
'シート名配列
C = 0
For Each Sht In wsMain.Parent.Worksheets
If Sht.Name = wsMain.Name Then '一覧表を除く
Else
C = C + 1
ReDim Preserve ShtNames(1 To C)
ShtNames(C) = Sht.Name
End If
Next
' 'シート名並べ替え
' ShtNames = Csort(ShtNames)
'ハイパーリンク設定
Set R = wsMain.Range(TopCellAddress)
For i = 1 To UBound(ShtNames)
Na = ShtNames(i)
Set Sht = wsMain.Parent.Worksheets(Na)
'一覧表
wsMain.Hyperlinks.Add anchor:=R, Address:="", _
SubAddress:="'" & Na & "'!A1", _
TextToDisplay:="'" & Na
'戻る
With Sht
.Range(adr一覧表に戻る).MergeArea.ClearContents
.Hyperlinks.Add anchor:=.Range(adr一覧表に戻る), Address:="", _
SubAddress:="'" & wsMain.Name & "'!" & R.Address(0, 0, xlA1, 0), _
TextToDisplay:="一覧表に戻る"
.Range(adr一覧表に戻る).Font.Size = 11
End With
'次の位置
If i Mod MaxRow = 0 Then
Set R = R.Offset(-(MaxRow - 1) * RowStep, ColStep)
Else
Set R = R.Offset(RowStep)
End If
Next
'一覧表フォントサイズ
wsMain.UsedRange.Font.Size = 11
End Sub
Private Function Csort(ByVal Ary As Variant) As Variant
'昇順並べ替え、引数は１次元配列のみ可。
Dim L As Long
Dim U As Long
Dim i As Long
Dim gap As Long
Dim Temp As Variant
Dim F As Boolean
L = LBound(Ary)
U = UBound(Ary)
gap = U - L
F = True
Do While gap > 1 Or F = True
gap = Int(gap / 1.3)
If gap = 9 Or gap = 10 Then
gap = 11
ElseIf gap < 1 Then
gap = 1
End If
F = False
For i = L To U - gap
If Ary(i) > Ary(i + gap) Then
Temp = Ary(i)
Ary(i) = Ary(i + gap)
Ary(i + gap) = Temp
F = True
End If
Next
Loop
Csort = Ary
End Function
'ブックの指定省略時はアクティブブックが対象
Sub test1()
CDPLet "Name1", "Value1"
MsgBox CDPGet("Name1")
End Sub
'ブックを明示的に指定も可能
Sub test2()
CDPLet "Name2", "Value2", Workbooks("book2.xls")
MsgBox CDPGet("Name2", Workbooks("book2.xls"))
End Sub
Public Sub CDPLet(PName As String, PValue As String, Optional ByVal Book As Workbook)
CheckCustomDocumentProperty PName, Book
Book.CustomDocumentProperties(PName).Value = PValue
End Sub
Public Function CDPGet(PName As String, Optional ByVal Book As Workbook) As String
CheckCustomDocumentProperty PName, Book
CDPGet = Book.CustomDocumentProperties(PName).Value
End Function
Private Sub CheckCustomDocumentProperty(CDPname As String, Book As Workbook)
Dim Flg As Boolean
Dim i As Long
If Book Is Nothing Then
Set Book = ActiveWorkbook
End If
With Book.CustomDocumentProperties
For i = 1 To .Count
If .Item(i).Name = CDPname Then
Flg = True
Exit For
End If
Next
If Not Flg Then
.Add Name:=CDPname, LinkToContent:=False, _
Type:=msoPropertyTypeString, Value:=""
End If
End With
End Sub
Sub test()
GetColumn(Range("A5")).Select
End Sub
'指定セルから最終行（そのシートの最終使用行）までの「１列」を返す
Function GetColumn(TopCell As Range) As Range
Dim RR As Range
With TopCell.Worksheet
Set RR = Intersect(TopCell.EntireColumn, .UsedRange)
Set RR = .Range(TopCell, RR.Rows(RR.Rows.Count))
End With
Set GetColumn = RR
End Function
Sub ▼任意表示()
Dim Afl As AutoFilter
Dim Ary As Variant
Dim i As Variant
Ary = Array(1, 9) '表示する列
Set Afl = ActiveSheet.AutoFilter 'オートフィルタは事前に設定済の前提
'一旦すべて非表示
For i = 1 To Afl.Filters.Count
Afl.Range.AutoFilter i, VisibleDropDown:=False
Next
'任意に表示
For Each i In Ary
Afl.Range.AutoFilter i, VisibleDropDown:=True
Next
End Sub
※Excel2000以上
※とりあえず、コマンドボタン・チェックボックス・オプションボタンのクリック、テキストボックスのチェンジの４イベントのみ ^d^
===== UserForm1 モジュール =====
Option Explicit
Private WithEvents cMyButtons As cCtrls
'クラスのコマンドボタンクリックイベントで一括処理
Private Sub cMyButtons_CmdClick(ByVal Ctrl As MSForms.CommandButton, ByVal Index As Long, ByVal Container As MSForms.Control)
Dim Msg As String
With Ctrl
Msg = "Caption=" & .Caption & vbCrLf
End With
Msg = Msg & "Index=" & Index & vbCrLf
With Container
Msg = Msg & "Name=" & .Name & vbCrLf
Msg = Msg & "TabIndex=" & .TabIndex & vbCrLf
Msg = Msg & "Left=" & .Left & vbCrLf
Msg = Msg & "Top=" & .Top & vbCrLf
End With
MsgBox Msg
End Sub
Private Sub UserForm_Initialize()
Dim Ctrl As MSForms.Control
Set cMyButtons = New cCtrls
'フォーム上のコマンドボタンをクラスに追加する
For Each Ctrl In Me.Controls
If TypeName(Ctrl) = "CommandButton" Then
If Ctrl.Caption = "OK" Or Ctrl.Caption = "キャンセル" Then
Else
cMyButtons.AddCtrl Ctrl
End If
End If
Next
End Sub
Private Sub UserForm_Terminate()
Set cMyButtons = Nothing
End Sub
===== cCtrls クラスモジュール =====
Option Explicit
'Excel2000以上
'Microsoft Forms 2.0 Object Library への参照設定要（UserFormを挿入すれば自動的に設定される）
'最終更新日：'11/10/27
Public Event TxtChange(ByVal Ctrl As MSForms.TextBox, ByVal Index As Long, ByVal Container As MSForms.Control)
Public Event CmdClick(ByVal Ctrl As MSForms.CommandButton, ByVal Index As Long, ByVal Container As MSForms.Control)
Public Event ChkClick(ByVal Ctrl As MSForms.CheckBox, ByVal Index As Long, ByVal Container As MSForms.Control)
Public Event OptClick(ByVal Ctrl As MSForms.OptionButton, ByVal Index As Long, ByVal Container As MSForms.Control)
Private myCtrls() As cCtrl
Private myCount As Long
Public Property Get Item(Index As Long) As MSForms.Control
If Index >= 0 And Index < myCount Then
Set Item = myCtrls(Index).Control
End If
End Property
Public Property Get Count() As Long
Count = myCount
End Property
Public Sub AddCtrl(Ctrl As MSForms.Control)
ReDim Preserve myCtrls(0 To myCount)
Set myCtrls(myCount) = New cCtrl
myCtrls(myCount).SetCtrl Ctrl, myCount, Me '子クラスに親を教えてあげるのがミソ
myCount = myCount + 1
End Sub
Public Sub Clear()
Dim i As Long
For i = 0 To myCount - 1
Set myCtrls(i) = Nothing
Next
Erase myCtrls
myCount = 0
End Sub
Private Sub Class_Terminate()
Me.Clear
End Sub
'子クラスからイベントが通知される
Friend Sub Ctrl_Click(Ctrl As MSForms.Control, Index As Long, Container As MSForms.Control)
Select Case TypeName(Ctrl)
Case "CommandButton"
RaiseEvent CmdClick(Ctrl, Index, Container)
Case "CheckBox"
RaiseEvent ChkClick(Ctrl, Index, Container)
Case "OptionButton"
RaiseEvent OptClick(Ctrl, Index, Container)
End Select
End Sub
Friend Sub Ctrl_Change(Ctrl As MSForms.Control, Index As Long, Container As MSForms.Control)
Select Case TypeName(Ctrl)
Case "TextBox"
RaiseEvent TxtChange(Ctrl, Index, Container)
End Select
End Sub
'===== UserFormモジュール =====
'Option Explicit
'
'Private WithEvents myButtons As cCtrls
'
'Private Sub myButtons_CmdClick(ByVal Ctrl As MSForms.CommandButton, ByVal Index As Long, ByVal Container As MSForms.Control)
' MsgBox "Caption=" & Ctrl.Caption & " Index=" & Index & " Name=" & Container.Name
'End Sub
'
'Private Sub UserForm_Click()
' Dim Msg As String
' Static C As Long
' If myButtons.Count >= 1 And C <= myButtons.Count - 1 Then
' With myButtons.Item(C)
' Msg = "Caption=" & .Caption
' Msg = Msg & vbCrLf & "Name=" & .Name
' MsgBox Msg
' .SetFocus
' End With
' End If
' C = C + 1
'End Sub
'
'Private Sub UserForm_Initialize()
' CreateButtons
'End Sub
'
'Private Sub UserForm_Terminate()
' Set myButtons = Nothing
'End Sub
'
'Private Sub CreateButtons()
' Dim myBtn As MSForms.Control
' Const N As Long = 31
' Const St As Long = 2
' Dim i As Long
' Dim L0 As Single, T0 As Single
' Dim L As Single, T As Single, W As Single, H As Single
' Dim Gap As Single
'
' Set myButtons = New cCtrls
' L0 = 10: T0 = 8: W = 28: H = 23
' Gap = 3
'
' For i = 1 To N
' Set myBtn = Me.Controls.Add("Forms.CommandButton.1")
' L = L0 + ((i - 1 + St - 1) Mod 7) * (Gap + W)
' T = T0 + ((i - 1 + St - 1) \ 7) * (Gap + H)
' With myBtn
' .Left = L: .Top = T: .Width = W: .Height = H
' .Caption = i
' End With
' myButtons.AddCtrl myBtn
' Next
'End Sub
===== cCtrl クラスモジュール =====
Option Explicit
'Excel2000以上
'最終更新日：'11/9/16
Private myParent As cCtrls '親クラスを保持しておくのがミソ
Private WithEvents myTxt As MSForms.TextBox
Private WithEvents myCmd As MSForms.CommandButton
Private WithEvents myChk As MSForms.CheckBox
Private WithEvents myOpt As MSForms.OptionButton
Private myIndex As Long
Private myCtrl As MSForms.Control 'Nameなどのコンテナ情報保持用
Friend Property Get Control() As MSForms.Control
Set Control = myCtrl
End Property
Friend Sub SetCtrl(Ctrl As MSForms.Control, Index As Long, Parent As cCtrls)
Select Case TypeName(Ctrl)
Case "TextBox"
Set myTxt = Ctrl
Case "CommandButton"
Set myCmd = Ctrl
Case "CheckBox"
Set myChk = Ctrl
Case "OptionButton"
Set myOpt = Ctrl
End Select
myIndex = Index
Set myParent = Parent
Set myCtrl = Ctrl
End Sub
Private Sub Class_Terminate()
Set myParent = Nothing
Set myTxt = Nothing
Set myCmd = Nothing
Set myChk = Nothing
Set myOpt = Nothing
Set myCtrl = Nothing
End Sub
'親クラスにイベントを返す
Private Sub myTxt_Change()
myParent.Ctrl_Change myTxt, myIndex, myCtrl
End Sub
Private Sub myCmd_Click()
myParent.Ctrl_Click myCmd, myIndex, myCtrl
End Sub
Private Sub myChk_Click()
myParent.Ctrl_Click myChk, myIndex, myCtrl
End Sub
Private Sub myOpt_Click()
If myOpt.Value Then
myParent.Ctrl_Click myOpt, myIndex, myCtrl
End If
End Sub
'===== TypeName =====
'CheckBox
'ComboBox
'CommandButton
'Frame
'Image
'Label
'ListBox
'MultiPage
'OptionButton
'ScrollBar
'SpinButton
'TabStrip
'TextBox
'ToggleButton
Sub test()
Dim Minn As Double, Maxx As Double, Stepp As Double
Dim Res As String
Minn = 910: Maxx = 940
Res = 目盛取り(Minn, Maxx, Stepp, 対数:=False, 分割数:=4, Log目盛1to9:=False)
If Res <> "" Then
MsgBox Res
Else
MsgBox Minn & ", " & Maxx & ", " & Stepp
End If
End Sub
Private Function 目盛取り(Minn As Double, Maxx As Double, Stepp As Double, 対数 As Boolean, _
Optional 分割数 As Integer = 6, Optional Log目盛1to9 As Boolean = False) As String
'リニア時目盛基本分割数(ﾃﾞﾌｫﾙﾄ 6)
'ログ目盛1to9 False;10^n True;1〜9*10^n
'Error ---> エラーメッセージ
'OK ---> "", Minn, Maxx, Stepp
Dim 分割数1 As Integer
Dim Log目盛129 As Boolean
Dim D1 As Double
Dim D2 As Double
Dim Ds As Double
Dim S As Integer
Dim Z As Integer
分割数1 = 分割数
Log目盛129 = Log目盛1to9
目盛取り = ""
'linear
If 対数 = False Then
'目盛間隔
Ds = Maxx - Minn
If Ds < 0 Then
目盛取り = "自動目盛取りが出来ません。(Max < Min)"
Exit Function
End If
If Ds = 0 Then
If Minn < 0 Then
Ds = 0 - Minn
D1 = Minn - Ds
D2 = 0
ElseIf Minn = 0 Then
Ds = 1
D1 = -1
D2 = 1
Else
Ds = Minn
D1 = 0
D2 = Minn + Ds
End If
Minn = D1
Maxx = D2
Stepp = Ds
Exit Function
End If
Ds = Ds / 分割数1
S = Int(Log(Ds) / Log(10) + 0.001)
Ds = Ds / 10 ^ S
Select Case Ds
Case Is < 1.41
Ds = 1
Case Is < 3.16
Ds = 2
Case Is < 7.07
Ds = 5
Case Else
Ds = 1
S = S + 1
End Select
If S > 0 Then
For Z = 1 To S
Ds = Ds * 10
Next
ElseIf S < 0 Then
For Z = -1 To S Step -1
Ds = Ds / 10
Next
End If
'最小目盛値
D1 = Int(Minn / Ds + 0.001) * Ds
If (Minn - D1) / Ds < 0.1 Then D1 = D1 - Ds
If D1 < 0 And Minn >= 0 Then D1 = 0
'最大目盛値
D2 = Int(Maxx / Ds + 0.999) * Ds
If (D2 - Maxx) / Ds < 0.1 Then D2 = D2 + Ds
'log
Else
If Minn <= 0 Or Maxx <= 0 Then
目盛取り = "対数目盛に 0 以下は適用出来ません。"
Exit Function
End If
Ds = -1 'ﾀﾞﾐｰ
'最小目盛値
S = Int(Log(Minn) / Log(10) + 0.001)
D1 = Int(Minn / 10 ^ S + 0.001)
If Log目盛129 = False Then D1 = 1
If S > 0 Then
For Z = 1 To S
D1 = D1 * 10
Next
ElseIf S < 0 Then
For Z = -1 To S Step -1
D1 = D1 / 10
Next
End If
'最大目盛値
S = Int(Log(Maxx) / Log(10) + 0.001)
D2 = Int(Maxx / 10 ^ S + 0.999)
If D2 = 10 Then
D2 = 1
S = S + 1
End If
If Log目盛129 = False Then
If D2 > 1 Then
D2 = 1
S = S + 1
End If
End If
If S > 0 Then
For Z = 1 To S
D2 = D2 * 10
Next
ElseIf S < 0 Then
For Z = -1 To S Step -1
D2 = D2 / 10
Next
End If
End If
Minn = D1
Maxx = D2
Stepp = Ds
End Function
===== 標準モジュール =====
Option Explicit
'アクティブセル(セル結合可)に一枚の画像を読み込む例
Sub Sample1()
Dim cLP As cLoadPicture
Dim FullPath As String
FullPath = Application.GetOpenFilename("画像ﾌｧｲﾙ(*.jpg),*.jpg")
If FullPath = "False" Then Exit Sub
Set cLP = New cLoadPicture
With cLP
Set .LoadPointCell = ActiveCell '読み込み位置指定
.PictureFullPath = FullPath '画像フルパス指定
.Margin = 2
If .LoadPicture Then '画像読み込み
Debug.Print "ok"
With .Picture
.Placement = xlMove
.OLEFormat.Object.PrintObject = True
'.OnAction = "拡大縮小" 'おまけ
End With
Else
Debug.Print "error"
End If
End With
Set cLP = Nothing
End Sub
'複数枚の画像を連続して読み込む例
Sub Sample2()
Dim cLP As cLoadPicture
Dim Fs As Variant
Dim F As Variant
Dim R As Range
Dim i As Long, j As Long
Dim c As Long
Fs = Application.GetOpenFilename("画像(*.jpg;*.jpeg),*.jpg;*.jpeg", MultiSelect:=True)
If VarType(Fs) = vbBoolean Then Exit Sub
Set cLP = New cLoadPicture
Set R = Range("B2")
For Each F In Fs
i = c \ 4
j = c Mod 4
Set cLP.LoadPointCell = R.Offset(i, j)
cLP.PictureFullPath = F
cLP.LoadPicture
'cLP.Picture.OnAction = "拡大縮小" 'おまけ
c = c + 1
Next
Set cLP = Nothing
End Sub
'おまけ
Sub 拡大縮小()
Dim cLP As cLoadPicture
Dim Pic As Shape
Dim W As Single, H As Single
Set Pic = ActiveSheet.Shapes(Application.Caller)
W = Pic.Width: H = Pic.Height
Set cLP = New cLoadPicture
With cLP
Set .Picture = Pic
Set .LoadPointCell = Pic.TopLeftCell
.ResetOriginalSize
Pic.ZOrder msoBringToFront
If Pic.Width = W And Pic.Height = H Then
.FitInTheCell
End If
End With
Set cLP = Nothing
End Sub
===== cLoadPicture クラスモジュール =====
Option Explicit
'最終更新日：2012/2/13
Public LoadPointCell As Range
Public PictureFullPath As String
Public Margin As Single
Public SetCenter As Boolean
Private Pic As Shape
Public Property Let MarginCm(Marginn As Single)
Margin = Application.CentimetersToPoints(Marginn)
End Property
Public Property Get Picture() As Shape
Set Picture = Pic
End Property
Public Property Set Picture(Pct As Shape)
Set Pic = Pct
End Property
Public Function LoadPicture() As Boolean
Set Pic = Nothing
If LoadPointCell Is Nothing Then Exit Function
If PictureFullPath = "" Then Exit Function
'画像の読み込み
On Error Resume Next
With LoadPointCell
Set Pic = .Worksheet.Shapes.AddPicture(PictureFullPath, LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=0, Height:=0)
End With
On Error GoTo 0
If Pic Is Nothing Then
Exit Function
End If
'オリジナルサイズに復元
ResetOriginalSize
'セル内に収める
FitInTheCell
LoadPicture = True
End Function
'オリジナルサイズに復元
Public Sub ResetOriginalSize()
If Pic Is Nothing Then Exit Sub
Pic.ScaleWidth 1, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
Pic.ScaleHeight 1, RelativeToOriginalSize:=msoTrue, Scale:=msoScaleFromTopLeft
Pic.Left = LoadPointCell.Left
Pic.Top = LoadPointCell.Top
End Sub
'セル内に収める
Public Sub FitInTheCell()
If LoadPointCell Is Nothing Then Exit Sub
If Pic Is Nothing Then Exit Sub
Dim rngTemp As Range 'セル範囲指定への対応
Dim PastWidth As Single
Dim PastHeight As Single
Dim RatioW As Single
Dim RatioH As Single
'念のために
Pic.Left = LoadPointCell.Left
Pic.Top = LoadPointCell.Top
'貼り付け先の大きさ
If LoadPointCell.Cells.Count = 1 Then
Set rngTemp = LoadPointCell.MergeArea
Else
Set rngTemp = LoadPointCell
End If
With rngTemp
PastWidth = .Width - Margin * 2
PastHeight = .Height - Margin * 2
End With
'画像と貼り付け先の大きさ比率
RatioW = Pic.Width / PastWidth
RatioH = Pic.Height / PastHeight
'比率の大きい方を基準に縮小する(比率が1未満の時は拡大となる)
With Pic
.LockAspectRatio = msoTrue
If RatioW > RatioH Then
.Width = .Width / RatioW
Else
.Height = .Height / RatioH
End If
End With
'中央に配置
If SetCenter Then
With Pic
.Left = .Left + (PastWidth + Margin * 2 - .Width) / 2
.Top = .Top + (PastHeight + Margin * 2 - .Height) / 2
End With
End If
Set rngTemp = Nothing
End Sub
Private Sub Class_Initialize()
Set LoadPointCell = ActiveCell
Margin = 2
SetCenter = True
End Sub
Sub Test()
Dim cAttr As cGetAttr
Dim myPath As String
myPath = Application.GetOpenFilename("すべてのファイル(*.*),*.*", Title:="検査対象")
If myPath = "False" Then Exit Sub
' myPath = "C:\Documents and Settings\user\デスクトップ\test\新規テキスト ドキュメント.txt"
Set cAttr = New cGetAttr
With cAttr
.FullPath = myPath
Debug.Print "Exist=" & .Exist
Debug.Print "FileName=" & .FileName
Debug.Print "Directory=" & .Directory
Debug.Print "ReadOnly=" & .ReadOnly
Debug.Print "Hidden=" & .Hidden
End With
Set cAttr = Nothing
End Sub
'Dir関数を使用しないファイル存在確認
Private Function Dir2(FullPath As String) As String
Dim cAttr As cGetAttr
Set cAttr = New cGetAttr
With cAttr
.FullPath = FullPath
If .Exist Then
Dir2 = .FileName
Else
Dir2 = ""
End If
End With
Set cAttr = Nothing
End Function
===== cGetAttr =====
Option Explicit
Private FileExist As Boolean
Private isReadOnly As Boolean
Private isHidden As Boolean
Private isSystem As Boolean
Private isDirectory As Boolean
Private isArchive As Boolean
Private FileNamee As String
Public Property Get Exist() As Boolean
Exist = FileExist
End Property
Public Property Get ReadOnly() As Boolean
ReadOnly = isReadOnly
End Property
Public Property Get Hidden() As Boolean
Hidden = isHidden
End Property
Public Property Get System() As Boolean
System = isSystem
End Property
Public Property Get Directory() As Boolean
Directory = isDirectory
End Property
Public Property Get Archive() As Boolean
Archive = isArchive
End Property
Public Property Get FileName() As String
FileName = FileNamee
End Property
Public Property Let FullPath(ByVal FulPath As String)
Dim myAttr As Integer
Dim Fname As Variant
If Right$(FulPath, 1) = "\" Then FulPath = Left$(FulPath, Len(FulPath) - 1)
On Error GoTo Trap
myAttr = GetAttr(FulPath)
On Error GoTo 0
If (myAttr And vbReadOnly) = vbReadOnly Then
isReadOnly = True
Else
isReadOnly = False
End If
If (myAttr And vbHidden) = vbHidden Then
isHidden = True
Else
isHidden = False
End If
If (myAttr And vbSystem) = vbSystem Then
isSystem = True
Else
isSystem = False
End If
If (myAttr And vbDirectory) = vbDirectory Then
isDirectory = True
Else
isDirectory = False
End If
If (myAttr And vbArchive) = vbArchive Then
isArchive = True
Else
isArchive = False
End If
FileExist = True
Fname = Split(FulPath, "\")
Fname = Fname(UBound(Fname))
If Fname Like "?:*" Then
Fname = Mid$(Fname, 3)
End If
FileNamee = Fname
Exit Property
Trap:
FileExist = False
FileNamee = ""
Exit Property
End Property
'テキストファイルの連結
Sub JoinTextFile()
Const FPattern As String = "test*_#.csv" '英字は小文字で指定
Dim Fpath As String
Dim Fname As String
Dim C As Integer
Dim Fls() As String
Dim i As Integer
Dim cTxt As cTextFile
Dim Txt As String
Set cTxt = New cTextFile
With cTxt
Fpath = .DeskTopPath & "\"
Fname = Dir(Fpath & "*.csv")
C = 0
Do Until Fname = ""
If LCase(Fname) Like FPattern Then
ReDim Preserve Fls(0 To C)
Fls(C) = Fname
C = C + 1
End If
Fname = Dir()
Loop
If C = 0 Then
Set cTxt = Nothing
MsgBox "対象ファイルがありません。", vbExclamation
Exit Sub
End If
.WritePath = Fpath & "sum.csv"
For i = 1 To C
.ReadPath = Fpath & Fls(i - 1)
Txt = .AllText
If i >= 2 Then .Append = True
If .EndReturn Then
.Write0 Txt
Else
.Write1 Txt
End If
Next
End With
Set cTxt = Nothing
End Sub
'テキストファイルをN行で分割
Sub SplitTextFile()
Const N As Long = 65536
Dim cTxt As cTextFile
Dim Txt As Variant
Dim Txt2 As Variant
Dim i As Long
Dim C As Long
Dim Fc As Long
Set cTxt = New cTextFile
With cTxt
.ReadPath = .DeskTopPath & "\test.csv"
Txt = .ArrayText
C = 0
For i = 0 To UBound(Txt)
If C = 0 Then ReDim Txt2(0 To N - 1)
Txt2(C) = Txt(i)
C = C + 1
If C = N Then
Fc = Fc + 1
Txt2 = Join(Txt2, .NewLineCode)
.WritePath = .ReadPath & "_" & Fc & ".csv"
.Write1 CStr(Txt2)
C = 0
ElseIf i = UBound(Txt) Then
ReDim Preserve Txt2(0 To UBound(Txt) Mod N)
Fc = Fc + 1
Txt2 = Join(Txt2, .NewLineCode)
.WritePath = .ReadPath & "_" & Fc & ".csv"
.Write1 CStr(Txt2)
End If
Next
End With
Set cTxt = Nothing
End Sub
'テキストファイル中の文字列置換え
Sub ReplaceString()
Dim cTxt As cTextFile
Dim cReg As cRegExp
Dim Txt As String
Dim Bf As String, Af As String
Dim C As Long
Dim Ans As Integer
Set cTxt = New cTextFile
Set cReg = New cRegExp
'Bf = "([A-Za-z])\1{2}" '同じ半角英字が３文字続いていたら
Bf = "ＡＢ" '全角
Af = "xyz" '半角
With cTxt
.ReadPath = .DeskTopPath & "\test.txt"
Txt = .AllText
With cReg
.Pattern = Bf
.Globall = True
If .ExeCute(Txt) Then
C = .MatchesCount
Ans = MsgBox(C & "件マッチしました。置き換えますか。", vbQuestion + vbOKCancel + vbDefaultButton2)
If Ans = vbOK Then
Txt = .Replace(Txt, Af)
Else
C = 0
End If
End If
End With
If C >= 1 Then
.WritePath = .ReadPath & "_Repl.txt" '元ファイルへ上書きなら & 以降は不要
.Write0 Txt
End If
End With
Set cTxt = Nothing
Set cReg = Nothing
End Sub
Option Explicit
Option Private Module
'世代バックアップ
Public Function GeneBak(ByVal TargetPath As String, Optional ByVal BakDir As String, _
Optional MaxGeneration As Integer = 9) As String
'TargetPathのファイルをBakDirにバックアップコピーする
'最大MaxGeneration世代まで、名前は後ろに _番号、0番が最新、後ろは順にReNameされる
'（途中に空き番号がある時はそれ以前の範囲でシフト）
'BakDirの最後の\有無は問わない、BakDir省略時はファイルパス\ファイル名_bakdir
Dim TargetName As String 'コピー元ファイル名
Dim Ext As String '拡張子
Dim Dummy As String
Dim i As Integer
Dim NSpace As Integer '途中の空き番号（空きが無い時は最大番号）、名前シフト範囲確定用
Dim NN As String 'フォーマットの番号部分書式 ex. "0", "00"
Dim OldPath As String
Dim NewPath As String
'世代最大数チェック
If MaxGeneration < 0 Then GeneBak = "世代最大数の指定が不正です。": Exit Function
'余分な空白削除
TargetPath = Trim$(TargetPath): BakDir = Trim$(BakDir)
'ファイルパス名確認
If TargetPath = "" Then GeneBak = "ファイル指定が無効です。": Exit Function
If TargetPath Like "*[:\\]" Then GeneBak = "ファイル指定が無効です。": Exit Function
'ファイルパスの存在確認
On Error Resume Next
TargetName = Dir(TargetPath)
On Error GoTo 0
If TargetName = "" Then GeneBak = "ファイルが見つかりません。": Exit Function
'ファイル名と拡張子の分離
Ext = GetExt(TargetName)
TargetName = Left$(TargetName, Len(TargetName) - Len(Ext))
'バックアップ先フォルダ名
If BakDir = "" Then BakDir = GetPath(TargetPath) & TargetName & "_bakdir"
If Right$(BakDir, 1) <> "\" Then BakDir = BakDir & "\" '最後の\が無ければ追加
'バックアップ先フォルダ存在確認
On Error Resume Next
Dummy = Dir(BakDir, vbDirectory)
On Error GoTo 0
If Dummy = "" Then
'無ければ作成
On Error GoTo Trap
MkDir BakDir
On Error GoTo 0
ElseIf (GetAttr(Dummy) And vbDirectory) <> vbDirectory Then
'同名ファイル在り
GeneBak = "指定フォルダと同名ファイルが存在します。" '上で\を付加しているので実際はここは意味が無い
Exit Function
End If
NN = String$(Len(Format$(MaxGeneration)), "0")
'途中の空き番号検索
NSpace = MaxGeneration
For i = 0 To MaxGeneration
OldPath = BakDir & TargetName & "_" & Format$(i, NN) & Ext
If Dir(OldPath) = "" Then
NSpace = i
Exit For
End If
Next
'既存バックアップの名前シフト
For i = NSpace - 1 To 0 Step -1
OldPath = BakDir & TargetName & "_" & Format$(i, NN) & Ext
NewPath = BakDir & TargetName & "_" & Format$(i + 1, NN) & Ext
If Dir(OldPath) <> "" Then
'最終番号のバックアップファイルが存在する時は予め削除する
If i = NSpace - 1 Then
If Dir(NewPath) <> "" Then
Err.Clear
On Error Resume Next
Kill NewPath
If Err.Number <> 0 Then
GeneBak = "最終バックアップファイルを削除できません。"
On Error GoTo 0
Exit Function
End If
On Error GoTo 0
End If
End If
On Error GoTo Trap
Name OldPath As NewPath
On Error GoTo 0
End If
Next
'バックアップコピー(コピー先番号は「0」)
On Error GoTo Trap
FileCopy TargetPath, BakDir & TargetName & "_" & NN & Ext
On Error GoTo 0
GeneBak = ""
Exit Function
Trap:
GeneBak = Err.Description
On Error GoTo 0
Exit Function
End Function
'拡張子取得
Private Function GetExt(Fname As String) As String
Dim i As Integer, j As Integer
Do
i = InStr(j + 1, Fname, ".")
If i >= 1 Then j = i
Loop Until i = 0
If j = 0 Then
GetExt = ""
Else
GetExt = Mid$(Fname, j)
End If
End Function
'パス取得
'実在ファイルのフルパスを渡す。ファイル名のみの時はカレントフォルダ名を返す。
Private Function GetPath(FullPath As String) As String
Dim myName As String
Dim myPath As String
myName = Dir(FullPath)
If LCase(myName) = LCase(FullPath) Then
myPath = CurDir
If Right$(myPath, 1) <> "\" Then myPath = myPath & "\"
Else
myPath = Left$(FullPath, Len(FullPath) - Len(myName))
End If
GetPath = myPath
End Function
Sub Sample_Count()
'テキストファイル中の特定文字列数をカウントする（※正規表現クラス、cRegExp使用）
Dim cTxt As cTextFile
Dim Txt As String
Const Key As String = "http://"
Dim cReg As cRegExp
Set cTxt = New cTextFile
With cTxt
.ReadPath = .DeskTopPath & "\test.html"
If .ErrorDescription <> "" Then
Set cTxt = Nothing
MsgBox .ErrorDescription, vbExclamation
Exit Sub
End If
Txt = .AllText '一気に読み込み
End With
Set cTxt = Nothing
'正規表現クラスでカウントする
Set cReg = New cRegExp
With cReg
.Pattern = Key
.Globall = True
.ExeCute Txt
Debug.Print .MatchesCount
End With
Set cReg = Nothing
End Sub
Sub Sample_GetLine()
'テキストファイル中のN行目を抽出する
Dim cTxt As New cTextFile
Dim Ary As Variant
Dim NN As Variant
Dim N As Variant
NN = Array(1, 3, 5)
Set cTxt = New cTextFile
With cTxt
.ReadPath = .DeskTopPath & "\test.html"
If .ErrorDescription <> "" Then
Set cTxt = Nothing
MsgBox .ErrorDescription, vbExclamation
Exit Sub
End If
Ary = .ArrayText '行データを配列に取得
For Each N In NN
If N - 1 <= UBound(Ary) Then
Debug.Print N; "行目 : "; Ary(N - 1); "*"
End If
Next
End With
Set cTxt = Nothing
End Sub
Sub Sample_Count2()
'テキストファイル中の特定文字列数をカウントする、その２(正規表現を使用せずDoLoop使用)
Dim cTxt As cTextFile
Dim Txt As String
Const Key As String = "http://"
Dim T As Single
Dim i As Long, j As Long
Dim C As Long
T = Timer
Set cTxt = New cTextFile
With cTxt
.ReadPath = .DeskTopPath & "\test.html"
If .ErrorDescription <> "" Then
MsgBox .ErrorDescription, vbExclamation
Exit Sub
End If
Txt = .AllText
End With
Set cTxt = Nothing
Debug.Print Timer - T
T = Timer
i = 0: j = 0
C = 0
Do
i = InStr(j + 1, Txt, Key)
If i >= 1 Then
C = C + 1
j = i + Len(Key)
End If
Loop Until i = 0
Debug.Print C
Debug.Print Timer - T
End Sub
Sub Sample_GetString()
'テキストファイルから特定文字列を別ファイルに抽出する（※正規表現クラス、cRegExp使用）
'（"http:// ... .jpg"）
Dim cTxt As cTextFile
Dim cReg As cRegExp
Dim Txt As String
Dim i As Long
Set cTxt = New cTextFile
Set cReg = New cRegExp
With cTxt
.ReadPath = .DeskTopPath & "\Test.html"
.WritePath = .ReadPath & "_Get.txt"
Txt = .AllText
End With
With cReg
.Pattern = "(http://.+\.jpg)"
.IgnoreCase = True
.Globall = True
If .ExeCute(Txt) Then
cTxt.Write1 .Value(0)
cTxt.Append = True
For i = 1 To .MatchesCount - 1
cTxt.Write1 .Value(i)
Next
End If
End With
Set cTxt = Nothing
Set cReg = Nothing
End Sub
===== cTextFile =====
Option Explicit
Private FullPath_Read As String '読み込みファイルのフルパス
Private TxtAll As String '一括で読み込んだテキスト
Private FullPath_Write As String '書き込みファイルのフルパス
Private flgAppend As Boolean 'Falseなら上書きモード、Trueなら追加モード
Private flgSaveChanges As Boolean '上書きモードの時、既存ファイルに上書きするかのフラグ
Private ErrorMsg As String 'エラー状態の説明（エラーがなければ""）
Private CrLf As String '改行コード
Private flgUnicode As Boolean 'TrueならUnicode、FalseならシフトJIS
Private flgEndReturn As Boolean '読み込んだファイルの最終改行有無フラグ
'※更新履歴
' '10/3/15 debug 別ファイル指定時の既読み込み値クリアを追加など
' '10/3/31 Dir関数を使用しないように変更し、外部のDir関数との干渉回避
' ⇒★★★★★ cGetAttrクラスを使用 ★★★★★
'●cTextFileクラスの機能
'１．テキストファイルの改行コードを含む一括読み込み
'２．テキストファイルを行毎に分割して配列に読み込み
'３．改行コードを任意に指定可能
'４．上書きモードまたは追加モードでテキストファイルへ書き込み
'５．書き込み時、最後に改行コードを付けるか付けないかを選択可
'６．シフトJISに加えて、Unicodeテキストも自動認識
'７．デスクトップパスとマイドキュメントパス取得のおまけ付き
'８．二次元配列から指定の一列を取得する関数（メソッド）のおまけ付き
'
'●プロパティとメソッド
'NewLineCodeプロパティ: 読み込み時の改行コードを指定します｡初期値はvbCrLf｡設定と取得が可能です｡String型を使用します｡
'ErrorDescriptionプロパティ: プロパティ設定やメソッド実行時のエラーメッセージを保持します｡取得のみ可能です｡String型を使用します｡
'Unicodeプロパティ: TrueがUnicode､FalseがシフトJISです｡ファイルを読み込むと自動で再設定されます｡初期値はFalse､設定と取得が可能です｡Boolean型を使用します｡
'EndReturnプロパティ: ファイルの最終に改行コードが在ったかどうかを示します｡ArrayTextプロパティで読み込んだ時､最終の改行が在ったか無かったかが分からないため､その確認の為のプロパティです｡Boolean型を使用します｡
'DeskTopPathプロパティ: 現在使用中のデスクトップのパスです｡取得のみ可能です｡String型を使用します｡
'MyDocumentPathプロパティ: 現在使用中のマイドキュメントのパスです｡取得のみ可能です｡String型を使用します｡
'GetColmnFromArrayメソッド：二次元配列から指定列を一次元配列(Index0から)として取り出します。forCell:=Trueとすることで、N行１列の二次元配列での取得も可能です。これはその値をそのままワークシート上に縦に貼り付ける時に便利な機能です。なお、配列以外を引数として渡しても、要素が1個の配列を返します。
'
'ReadPathプロパティ：読み込み用テキストファイルのフルパスです。設定と取得が可能です。String型を使用します。設定時、指定ファイルが見つからない場合はErrorDescriptionにその旨が設定されます。見つかった場合にはErrorDescriptionのそれまでの値はクリア（""）されます。
'ReadFileNameプロパティ：ReadPathプロパティのファイル名のみの部分（最後の「\」の後ろ）を返します。取得のみ可能です。String型を使用します。
'ReadAllメソッド：ファイルの内容を改行を含めてすべて読み込み、成功したか否かの結果を返します。Boolean型を使用します。失敗した場合はErrorDescriptionにその旨が設定されます。なお、読み込んだ結果はAllTextまたはArrayTextプロパティで取得します。シフトJISかUnicodeかは自動判別し、その結果はUnicodeプロパティに保持されます。
'AllTextプロパティ: 現在保持している読み込んだテキストを返します｡まだ読み込んでいない場合は内部でReadAllメソッドが実行されます｡取得のみ可能です｡String型を使用します｡
'ArrayTextプロパティ：現在保持している読み込んだテキストを、行毎に分割して配列で返します。まだ読み込んでいない場合は内部でReadAllメソッドが実行されます。取得のみ可能です。Variant型を使用します。なお、最終の改行が在っても空の要素は付加されません。このプロパティは実行の都度、あらためて行の分割が行なわれます（分割した結果はクラス内に保持されません）。大きなテキストの場合は注意してください。
'
'Appendプロパティ: Trueで追加モード､Falseで上書きモードの指定です｡初期値はFalseです｡設定のみ可能です｡Boolean型を使用します｡
'SaveChangesプロパティ：上書きモード(Append=False)の時、既存ファイルに対して強制的に上書きするかのフラグ。初期値はTrue。設定のみ可能です。Boolean型を使用します。既存ファイルがあった時に上書きしたくない時にFalseに設定します。
'WritePathプロパティ：書き込み用テキストファイルのフルパスです。設定と取得が可能です。String型を使用します。設定時、ファイル既存＆上書きモード＆上書き指定でない場合はErrorDescriptionにその旨（"指定ファイルが既に存在します。"）が設定されます。そうでない場合にはErrorDescriptionのそれまでの値はクリア（""）されます。
'WriteFileNameプロパティ：WritePathプロパティのファイル名のみの部分（最後の「\」の後ろ）を返します。取得のみ可能です。String型を使用します。
'Write1メソッド: 引数の変数の内容をテキストファイルに書き込みます｡最後に改行も追加で書き込み､成功したか否かの結果を返します｡Boolean型を使用します｡失敗した場合はErrorDescriptionにその旨が設定されます｡
'Write0メソッド: 引数の変数の内容をテキストファイルに書き込みます｡改行の追加書き込みはしません｡成功したか否かの結果を返します｡Boolean型を使用します｡失敗した場合はErrorDescriptionにその旨が設定されます｡
'
'●注意事項
'WritePathプロパティの設定は、AppendプロパティとSaveChangesプロパティを設定してから行なってください。但し、上書きモード（Append=False）で強制上書き（SaveChanges=True）の時はその値が初期値なので特に設定の必要はありません。
'既存ファイルの上書きに失敗すると、「元ファイル名.bak」という名前のファイルが残る場合があります。
Private Sub Class_Initialize()
ErrorMsg = ""
CrLf = vbCrLf
flgUnicode = False
flgAppend = False
flgSaveChanges = True
End Sub
Private Sub Class_Terminate()
TxtAll = ""
End Sub
'改行コード
Public Property Let NewLineCode(NewLnCode As String)
If NewLnCode <> "" Then
CrLf = NewLnCode
End If
End Property
Public Property Get NewLineCode() As String
NewLineCode = CrLf
End Property
'エラー状態の説明（エラーがなければ""）
Public Property Get ErrorDescription() As String
ErrorDescription = ErrorMsg
End Property
'Unicodeフラグ
Public Property Let Unicode(UniCD As Boolean)
flgUnicode = UniCD
End Property
Public Property Get Unicode() As Boolean
Unicode = flgUnicode
End Property
'読み込んだファイルの最終改行有無フラグ
Public Property Get EndReturn() As Boolean
EndReturn = flgEndReturn
End Property
'デスクトップのパス（おまけ）
Public Property Get DeskTopPath() As String
DeskTopPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop")
End Property
'マイドキュメントのパス（おまけ）
Public Property Get MyDocumentPath() As String
MyDocumentPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
End Property
'二次元配列から指定列を一次元配列(Index0から)として取り出す（おまけ）
Public Function GetColumnFromArray(Ary As Variant, ByVal Column As Long, _
Optional forCell As Boolean) As Variant
Dim V As Variant
Dim i As Long
Dim C As Long
If Right$(TypeName(Ary), 2) <> "()" Then
If forCell Then
ReDim V(0 To 0, 0 To 0)
V(0, 0) = Ary
GetColumnFromArray = V
Else
GetColumnFromArray = Array(Ary)
End If
Exit Function
End If
If forCell Then
ReDim V(0 To UBound(Ary) - LBound(Ary), 0 To 0)
Else
ReDim V(0 To UBound(Ary) - LBound(Ary))
End If
If Column < LBound(Ary, 2) Then Column = LBound(Ary, 2)
If Column > UBound(Ary, 2) Then Column = UBound(Ary, 2)
C = 0
If forCell Then
For i = LBound(Ary) To UBound(Ary)
V(C, 0) = Ary(i, Column)
C = C + 1
Next
Else
For i = LBound(Ary) To UBound(Ary)
V(C) = Ary(i, Column)
C = C + 1
Next
End If
GetColumnFromArray = V
End Function
'＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊ 読み込み ＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
'読み込みテキストファイルのフルパス
Public Property Let ReadPath(FullName As String)
Dim Fname As String
On Error GoTo Trap
Fname = Dir2(FullName)
On Error GoTo 0
If Fname = "" Then
ErrorMsg = "指定ファイルが見つかりません。"
FullPath_Read = ""
TxtAll = ""
Else
ErrorMsg = ""
If FullName <> FullPath_Read Then
TxtAll = "" '別ファイル指定時は既読み込み値クリア
End If
FullPath_Read = FullName
End If
Exit Property
Trap:
ErrorMsg = Err.Description
FullPath_Read = ""
On Error GoTo 0
End Property
Public Property Get ReadPath() As String
ReadPath = FullPath_Read
End Property
'読み込みのファイル名のみの取得
Public Property Get ReadFileName() As String
Dim V As Variant
If FullPath_Read = "" Then
ReadFileName = ""
Else
V = Split(FullPath_Read, "\")
ReadFileName = V(UBound(V))
End If
End Property
'すべて読み込み（成功：True、失敗：False）
Public Function ReadAll() As Boolean
Dim N As Integer
Dim bTxt() As Byte
If ErrorMsg <> "" Then
ReadAll = False
Exit Function
End If
If FullPath_Read = "" Then
ErrorMsg = "読み込みファイルの指定がありません。"
ReadAll = False
Exit Function
End If
N = FreeFile
On Error GoTo Trap
Open FullPath_Read For Binary Access Read Lock Write As #N
ReDim bTxt(1 To LOF(N))
Get #N, 1, bTxt()
TxtAll = CStr(bTxt)
If bTxt(1) = 255 And bTxt(2) = 254 Then
'Unicode
flgUnicode = True
Else
'シフトJIS
flgUnicode = False
End If
Erase bTxt
If flgUnicode Then
TxtAll = MidB$(TxtAll, 3)
Else
TxtAll = StrConv(TxtAll, vbUnicode)
End If
Close #N
If Right$(TxtAll, Len(CrLf)) = CrLf Then
flgEndReturn = True
Else
flgEndReturn = False
End If
On Error GoTo 0
ErrorMsg = ""
ReadAll = True
Exit Function
Trap:
ErrorMsg = Err.Description
Close #N
On Error GoTo 0
ReadAll = False
Exit Function
End Function
'一変数に読み込んで取得（.ReadAll省略可）
Public Property Get AllText() As String
If TxtAll = "" Then ReadAll
If ErrorMsg <> "" Then
AllText = ErrorMsg
Exit Property
End If
AllText = TxtAll
End Property
'読み込んだテキストを配列に分割して取得（.ReadAll省略可）
Public Property Get ArrayText() As Variant
Dim VV As Variant
If TxtAll = "" Then ReadAll
If ErrorMsg <> "" Then
ArrayText = Array(ErrorMsg)
Exit Property
End If
VV = Split(TxtAll, CrLf)
If flgEndReturn Then
ReDim Preserve VV(LBound(VV) To UBound(VV) - 1)
End If
ArrayText = VV
Erase VV
End Property
'＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊ 書き込み ＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
'追加書き込みモード指定
Public Property Let Append(AppendMode As Boolean)
flgAppend = AppendMode
End Property
'上書きフラグ（上書きモード(flgAppend=False)の時、既存ファイルに対して強制的に上書きするかのフラグ）
Public Property Let SaveChanges(SaveChange As Boolean)
flgSaveChanges = SaveChange
End Property
'書き込みテキストファイルのフルパス
Public Property Let WritePath(FullName As String)
Dim Fname As String
On Error GoTo Trap
Fname = Dir2(FullName)
On Error GoTo 0
If Fname <> "" And flgAppend = False And flgSaveChanges = False Then
'ファイル既存＆上書きモード＆上書き指定でないなら
ErrorMsg = "指定ファイルが既に存在します。"
FullPath_Write = ""
Else
ErrorMsg = ""
FullPath_Write = FullName
End If
Exit Property
Trap:
ErrorMsg = Err.Description
FullPath_Write = ""
On Error GoTo 0
End Property
Public Property Get WritePath() As String
WritePath = FullPath_Write
End Property
'書き込みのファイル名のみ
Public Property Get WriteFileName() As String
Dim V As Variant
If FullPath_Write = "" Then
WriteFileName = ""
Else
V = Split(FullPath_Write, "\")
WriteFileName = V(UBound(V))
End If
End Property
'書き込み（最終改行有り）
Public Function Write1(Txt As String) As Boolean
Write1 = WriteSub(Txt, True)
End Function
'書き込み（最終改行無し）
Public Function Write0(Txt As String) As Boolean
Write0 = WriteSub(Txt, False)
End Function
'書き込みサブ（成功：True、失敗：False）
Private Function WriteSub(Txt As String, EndRet As Boolean) As Boolean
Dim N As Integer
Dim Bt(1 To 2) As Byte
Dim bTxt() As Byte
Dim i As Long
Dim bakPath As String '書き込み失敗時の保険用ファイルパス
If ErrorMsg <> "" Then
WriteSub = False
Exit Function
End If
If FullPath_Write = "" Then
ErrorMsg = "書き込みファイルの指定がありません。"
WriteSub = False
Exit Function
End If
On Error GoTo Trap
'ファイルが既存で上書きモード（追加モードでなく）で上書き指定の時は _
一旦既存ファイルをリネームしておく
If Dir2(FullPath_Write) <> "" Then
If flgAppend Then
'nop
ElseIf flgSaveChanges = True Then 'Falseは上で除外しているからここはTrueしか有りあえないが、コード変更時の保険
'Kill FullPath_Write
bakPath = FileBackup(FullPath_Write) '一旦リネームしてとっておく
Else
ErrorMsg = "既存ファイルに上書きは出来ません。" '同上で保険
WriteSub = False
On Error GoTo 0
Exit Function
End If
End If
N = FreeFile
Open FullPath_Write For Binary Access Write Lock Read Write As #N
'Unicodeの印
If flgUnicode Then
'上書きモードまたは追加モードでもファイルが新規の時
If LOF(N) = 0 Then
Bt(1) = 255: Bt(2) = 254
Put #N, 1, Bt()
End If
End If
'書き込み位置は最後＋１バイト目
If flgUnicode Then
ReDim bTxt(1 To LenB(Txt))
bTxt = Txt
Put #N, LOF(N) + 1, bTxt
Erase bTxt
Else
Put #N, LOF(N) + 1, Txt
End If
'最終改行
If EndRet Then
If flgUnicode Then
ReDim bTxt(1 To LenB(CrLf))
bTxt = CrLf
Put #N, LOF(N) + 1, bTxt
Erase bTxt
Else
Put #N, LOF(N) + 1, CrLf
End If
End If
Close #N
If bakPath <> "" Then Kill bakPath '念のためのバックアップ元ファイルを削除
On Error GoTo 0
ErrorMsg = ""
WriteSub = True
Exit Function
Trap:
ErrorMsg = Err.Description
Close #N
On Error GoTo 0
WriteSub = False
Exit Function
End Function
'.bakとファイル名を変更し、そのファイル名を返す
Private Function FileBackup(FullPath As String) As String
Dim Fpath As String
Dim Dummy As String
Fpath = FullPath
Do
Fpath = Fpath & ".bak"
Dummy = Dir2(Fpath)
Loop Until Dummy = ""
Name FullPath As Fpath
FileBackup = Fpath
End Function
'Dir関数を使用しないファイル存在確認
Private Function Dir2(FullPath As String) As String
Dim cAttr As cGetAttr
Set cAttr = New cGetAttr
With cAttr
.FullPath = FullPath
If .Exist Then
Dir2 = .FileName
Else
Dir2 = ""
End If
End With
Set cAttr = Nothing
End Function
'Sub Test1() '単純に全体を読み込み
' Dim cTxt As cTextFile
'
' Set cTxt = New cTextFile
'
' With cTxt
' .ReadPath = .DeskTopPath & "\Sample.log"
' If .ReadAll Then
' Debug.Print .AllText
' Else
' Debug.Print .ErrorDescription
' End If
' End With
'
' Set cTxt = Nothing
'End Sub
'
'Sub Test2() '各行を配列に読み込み
' Dim cTxt As cTextFile
' Dim VV As Variant
' Dim i As Long
'
' Set cTxt = New cTextFile
'
' With cTxt
' .ReadPath = .DeskTopPath & "\Sample2.log"
' If .ErrorDescription <> "" Then
' Debug.Print .ErrorDescription
' Else
' VV = .ArrayText
' For i = 0 To UBound(VV)
' Debug.Print "*"; VV(i); "*"
' Next
' End If
' End With
'
' Set cTxt = Nothing
'End Sub
'
'Sub Test3() '変数の内容を単純に書き込み
' Dim cTxt As cTextFile
' Dim Txt As String
'
' Set cTxt = New cTextFile
' Txt = "テスト３"
'
' With cTxt
' .WritePath = .DeskTopPath & "\Test3.txt"
' If .Write1(Txt) Then
' Debug.Print "ok"
' Else
' Debug.Print .ErrorDescription
' End If
' End With
'
' Set cTxt = Nothing
'End Sub
'
'Sub Test4() '色々な書き込み
' Dim cTxt As cTextFile
'
' Set cTxt = New cTextFile
'
' With cTxt
' .SaveChanges = False '既存ファイルへの上書き禁止（但し追加は除く）
'' .Append = True '追加書き込みの指定
'' .Unicode = True 'Unicodeの指定
' '(シフトJISファイルにUnicodeで追加などというような無茶な指定はしないように^^;)
' '(もし、Appendモード時に自動でUnicode判別したければ、一旦ダミーでそのファイルを読み込めば良い。)
' .WritePath = .DeskTopPath & "\Test4.txt"
' If .ErrorDescription <> "" Then
' Debug.Print .ErrorDescription
' Else
' If .Write0("テスト４") Then '改行無し
' Debug.Print "ok"
' Else
' Debug.Print .ErrorDescription
' End If
' End If
' End With
'
' Set cTxt = Nothing
'End Sub
'
'Sub Test5() '読み込んだファイルの最初と最後の行を別ファイルに出力
' Dim cTxt As cTextFile
' Dim VV As Variant
'
' Set cTxt = New cTextFile
'
' With cTxt
' .ReadPath = .DeskTopPath & "\Sample2.log"
' VV = .ArrayText
' .WritePath = .ReadPath & "_2.txt"
' .Write1 CStr(VV(LBound(VV)))
' .Append = True
' .Write1 CStr(VV(UBound(VV)))
' End With
'
' Set cTxt = Nothing
'End Sub
'ワークシートN枚のブックを新規に作成して返す
Public Function CreateWb(N As Integer) As Workbook
Dim Cbak As Long
Cbak = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = N
Set CreateWb = Workbooks.Add
Application.SheetsInNewWorkbook = Cbak
End Function
===== cRegExp =====
Option Explicit
Private RegEx As Object
Private Matches As Object
Private strValue As String 'LeftValue, RightValue用
Public Property Let Pattern(Ptn As String)
RegEx.Pattern = Ptn
End Property
Public Property Let Globall(Glb As Boolean)
RegEx.Global = Glb
End Property
Public Property Let IgnoreCase(IgCase As Boolean)
RegEx.IgnoreCase = IgCase
End Property
Public Property Let MultiLine(MultiLin As Boolean)
RegEx.MultiLine = MultiLin
End Property
Public Function ExeCute(Stringg As String) As Boolean
ExeCute = RegEx.Test(Stringg)
Set Matches = RegEx.ExeCute(Stringg)
strValue = Stringg
End Function
Public Function Test(Stringg As String) As Boolean
Test = RegEx.Test(Stringg)
End Function
Public Function Replace(String1 As String, String2 As String) As String
Replace = RegEx.Replace(String1, String2)
End Function
Public Property Get MatchesCount() As Long
If Not Matches Is Nothing Then
MatchesCount = Matches.Count
End If
End Property
Public Property Get SubMatchesCount() As Long
'リマーク内記述は、ExeCute無しでパターン指定のみからサブマッチ数を返すもの
' Dim myRegExp As cRegExp
' Dim myStr As String
'
' myStr = RegEx.Pattern
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "\([^\?][^()]+\)"
' .Globall = True
' .IgnoreCase = False
' .ExeCute myStr
' SubMatchesCount = .MatchesCount
' End With
' Set myRegExp = Nothing
If Not Matches Is Nothing Then
SubMatchesCount = Matches(0).SubMatches.Count
End If
End Property
'各Indexは０から
Public Property Get FirstIndex(Optional MatchIndex As Long) As Long
FirstIndex = Matches(MatchIndex).FirstIndex
End Property
Public Property Get Length(Optional MatchIndex As Long) As Long
Length = Matches(MatchIndex).Length
End Property
Public Property Get Value(Optional MatchIndex As Long) As String
Value = Matches(MatchIndex).Value
End Property
Public Property Get SubMatchesValue(Optional MatchIndex As Long, _
Optional SubMatchIndex As Long) As String
SubMatchesValue = Matches(MatchIndex).SubMatches(SubMatchIndex)
End Property
Public Property Get LeftValue(Optional MatchIndex As Long) As String
Dim i As Long
i = Matches(MatchIndex).FirstIndex
LeftValue = VBA.Left$(strValue, i)
End Property
Public Property Get RightValue(Optional MatchIndex As Long) As String
Dim i As Long
Dim L As Long
With Matches(MatchIndex)
i = .FirstIndex
L = .Length
End With
RightValue = VBA.Mid$(strValue, i + L + 1)
End Property
Private Sub Class_Initialize()
Set RegEx = CreateObject("VBScript.RegExp")
Set Matches = Nothing
Globall = False '最初の一致だけを検索
IgnoreCase = False '大文字と小文字を区別する
End Sub
Private Sub Class_Terminate()
Set RegEx = Nothing
Set Matches = Nothing
End Sub
'Sub RegExpTest() '一般例
' Dim myRegExp As cRegExp
' Dim myStr As String
' Dim i As Long
'
' myStr = "1aa2a34aaa5"
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "\d\D\d"
' .Globall = False
' .IgnoreCase = False
' If .ExeCute(myStr) Then 'マッチ有無の確認だけなら.Testが良い
' Debug.Print .Value '"2a3"
' Debug.Print .FirstIndex '3 （オフセット）
' Debug.Print .Length '3
' Debug.Print .LeftValue '"1aa"
' Debug.Print .RightValue '"4aaa5"
' End If
' End With
' Set myRegExp = Nothing
'End Sub
'
'Sub RegExpTest2() '全て検索
' Dim myRegExp As cRegExp
' Dim myStr As String
' Dim i As Long
'
' myStr = "1aa2a34aaa5"
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "\d+"
' .Globall = True '全て検索
' .IgnoreCase = False
' .ExeCute myStr
' For i = 0 To .MatchesCount - 1
' Debug.Print .Value(i) '1, 2, 34, 5
' Next
' End With
' Set myRegExp = Nothing
'End Sub
'
'Sub ReplaceTest() 'すべて置換え
' Dim myRegExp As cRegExp
' Dim myStr As String
'
' myStr = "1aa2a34aaa5"
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "\d+"
' .Globall = True
' .IgnoreCase = False
' myStr = .Replace(myStr, "0")
' End With
' Set myRegExp = Nothing
'
' Debug.Print myStr '0aa0a0aaa0
'End Sub
'
'Sub ReplaceTest2() 'サブマッチを使い置換え
' Dim myRegExp As cRegExp
' Dim myStr As String
'
' myStr = "The quick brown fox jumped over the lazy dog."
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "(\S+)(\s+)(\S+)"
' .Globall = True
' .IgnoreCase = False
' myStr = .Replace(myStr, "$3$2$1")
' End With
' Set myRegExp = Nothing
'
' Debug.Print myStr 'quick The fox brown over jumped lazy the dog.
'End Sub
'
'Sub 後方参照Test()
' Dim myRegExp As cRegExp
' Dim myStr As String
'
' myStr = "Is is the cost of of gasoline going up up?."
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "\b([a-z]+) \1\b" '\1が1つ目のサブマッチ([a-z]+)にマッチした【内容】と同一
' .Globall = True
' .IgnoreCase = True
' myStr = .Replace(myStr, "$1")
' End With
' Set myRegExp = Nothing
'
' Debug.Print myStr 'Is the cost of gasoline going up?.
'End Sub
'
'Sub 後方参照Test2()
' Dim myRegExp As cRegExp
' Dim myStr As String
'
' myStr = "aaa123-abcd-9876-123-456"
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "(\d{3}).+\1" '\1が1つ目のサブマッチにマッチした【内容】と同一
' .Globall = True
' .IgnoreCase = True
' If .ExeCute(myStr) Then
' Debug.Print .Value(0) '123-abcd-9876-123
' Else
' Debug.Print "NoMatch"
' End If
' End With
' Set myRegExp = Nothing
'End Sub
'
'Sub SubMatchTest() 'サブマッチの値を使用（使用時はマッチ数、サブマッチ数に注意）
' Dim myRegExp As cRegExp
' Dim myStr As String
'
' myStr = "1aa2a34aaa5"
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "(\d)\D+(\d)"
' .Globall = True
' .IgnoreCase = False
' .ExeCute myStr
' Debug.Print .SubMatchesValue(0, 0) '"1" （"1aa2"の"1"）
' Debug.Print .SubMatchesValue(1, 1) '"5" （"4aaa5"の"5"）
' End With
' Set myRegExp = Nothing
'End Sub
'
'Sub 肯定先読みTest()
' Dim myRegExp As cRegExp
' Dim myStr1 As String
' Dim myStr2 As String
' Dim i As Long
'
' myStr1 = "Windows NT Win 2000"
' myStr2 = "Windows 3.1"
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "(Windows|Win) (?=95|98|NT|2000)" '肯定先読み(?=)
' .Globall = True
' .IgnoreCase = False
'
' If .ExeCute(myStr1) Then
' For i = 0 To .MatchesCount - 1
' Debug.Print .Value(i) '"Windows", "Win"
' Next
' Else
' Debug.Print "NoMatch"
' End If
'
' If .ExeCute(myStr2) Then
' Debug.Print .Value(0)
' Else
' Debug.Print "NoMatch" 'こちら
' End If
' End With
' Set myRegExp = Nothing
'End Sub
'
'Sub 肯定先読みTest2()
' Dim myRegExp As cRegExp
' Dim myStr As String
' Dim i As Long
'
' myStr = "1-3abc-d57"
'
' Set myRegExp = New cRegExp
' With myRegExp
' .Pattern = "\d(?=.+\d\d)" '肯定先読み
' .Globall = True
' .IgnoreCase = False
'
' If .ExeCute(myStr) Then
' For i = 0 To .MatchesCount - 1
' Debug.Print .Value(i) '"1-3abc-d57"から"1"、"3abc-d57"から"3"
' Next
' Else
' Debug.Print "NoMatch"
' End If
' End With
' Set myRegExp = Nothing
'End Sub
'パターン文字とその内容
'文字 内容
'\ 次に続く文字が特別な文字またはリテラルであることを示します。たとえば、"n" は "n" _
という文字と一致します。"\n"は、改行文字と一致します。"\\" は、"\" と一致します。 _
"\(" は "(" と一致します。
'^ 入力の開始と一致します。
'$ 入力の終端と一致します。
'* 直前の文字と 0 回以上一致します。たとえば、"zo*" は "z" とも "zoo" とも一致します。
'+ 直前の文字と 1 回以上一致します。たとえば、"zo+" は "zoo" とは一致しますが、"z" _
とは一致しません。
'? 直前の文字と; 0; 回または; 1; 回一致します｡たとえば､; "a?ve?"; は; "never"; の; _
"ve"; に一致します｡
'. 改行文字以外の任意の単独文字と一致します｡
'(pattern) 引数 pattern に指定した文字と一致します。一致する文字列が見つかったら、記憶さ _
れます。一致した部分は、Matches コレクションの項目 [0]...[n] から取得できます。 _
かっこ文字、() を指定するには、"\(" および "\)" を使用します。※最下行も参照のこと
'x|y x と y のどちらかと一致します。たとえば、"z|wood" は "z" と "wood" に一致します。 _
"(z|w)oo" は、"zoo" と "wood" に一致します。
'{n} n には、0 以上の整数を指定します。直前の文字と正確に n 回一致します。たとえば、 _
"o{2}" は、"Bob" の "o" とは一致しませんが、"foooood" の最初の 2 つの o とは一致 _
します。
'{n,} n には、0 以上の整数を指定します。直前の文字と少なくとも n 回一致します。 _
たとえば、"o{2,}" は、"Bob" の "o" とは一致しませんが、"foooood" のすべての o _
と一致します。"o{1,}" は、"o+" と同じ意味になります。"o{0,}" は、"o*" と同じ意味 _
になります。
'{n,m} m および n には、0 以上の整数を指定します。直前の文字と n 〜 m 回一致します。 _
たとえば、"o{1,3}" は、"fooooood" の最初の 3 つの o と一致します。"o{0,1}" は、 _
"o?" と同じ意味になります。
'[xyz] 文字セット。角かっこで囲まれた文字の中のいずれかと一致します。たとえば、"[abc]" _
は "plain" の "a" と一致します。
'[^xyz] 否定の文字セット。角かっこで囲まれた文字にはない任意の文字と一致します。"[^abc]" _
は、"plain" の "p" と一致します。
'[a-z] 文字の範囲。指定した範囲に含まれる任意の文字に一致します。たとえば、"[a-z]" は、 _
"a" から "z" までの任意のアルファベットの小文字に一致します。
'[^m-z] 否定の文字の範囲。指定した範囲に含まれていない任意の文字に一致します。たとえば、 _
"[^m-z]" は "m" から "z" までの範囲に含まれない任意の文字に一致します。
'\b 単語の境界と一致します。単語の境界とは、単語とスペースの間の位置のことです。 _
たとえば、"er\b" は、"never" の "er" に一致します。"verb" の "er" には一致しません。
'\B 単語の境界ではない部分と一致します。たとえば、"ea*r\B" は、"never early" の _
"ear" と一致します。
'\d 数字と一致します。[0-9] と指定した場合と同じ意味になります。
'\D 数字以外の文字と一致します。[^0-9] と指定した場合と同じ意味になります。
'\f フォームフィード文字と一致します。
'\n 改行文字と一致します。
'\r キャリッジ リターン文字と一致します。
'\s スペース、タブ、フォームフィードなどの任意の空白文字と一致します。 _
"[ \f\n\r\t\v]" と指定した場合と同じ意味になります。
'\S 空白文字のない部分と一致します。"[^ \f\n\r\t\v]" と指定した場合と同じ意味になります。
'\t タブ文字と一致します。
'\v 垂直タブ文字と一致します。
'\w 単語に使用される任意の文字と一致します。これには、アンダースコアも含まれます。 _
"[A-Za-z0-9_]" と指定した場合と同じ意味になります。
'\W 単語に使用される文字以外の任意の文字と一致します。"[^A-Za-z0-9_]" と指定した場合 _
と同じ意味になります。
'\num num には、正の整数を指定します。既に見つかり、記憶されている部分と一致します。 _
たとえば、"(.)\1" は、連続する 2 つの同じ文字に一致します。
'\n n に指定した 8 進数のエスケープ値と一致します。8 進数の値には、1 桁、2 桁、または _
3 桁で指定します。たとえば、"\11" と "\011" は、両方ともタブ文字に一致します。 _
"\0011" は、"\001" および "1" と同じ意味になります。8 進数のエスケープ値は、256 _
を超えることはできません。256 を超える数値を指定した場合、初めの 2 桁で値が評価 _
されます。この表記により、正規表現で ASCII コードを使用できるようになります。
'\xn n に指定した 16 進数のエスケープ値と一致します。16 進数のエスケープ値は、2 桁で _
ある必要があります。たとえば、"\x41" は、"A" に一致します。"\x041" は、"\x04" _
および "1"と同じ意味になります。この表記により、正規表現で ASCII コードを使用でき _
るようになります。
'以下、正規表現の構文より追加
'\num num に一致します。ここで num は正の整数です。記憶された一致文字列への後方参照です。 _
たとえば、'(.)\1' は 2 つの連続した同一文字に一致します。
'\n 8 進エスケープ値または後方参照のいずれかを表します。\n の前に保存されたサブ式が _
少なくとも n 個存在する場合、n は後方参照を表します。 _
それ以外の場合で n が 8 進数 (0 〜 7) である場合、n は 8 進エスケープ値を表します。
'\nm 8 進エスケープ値または後方参照のいずれかを表します。\nm の前に保存されたサブ式が _
少なくとも nm 個存在する場合、\nm は後方参照を表します。\nm の前に保存された _
サブ式が少なくとも n 個存在する場合、後方参照 n の後にリテラル m が続いていること _
を表します。 _
それ以外の場合で n と m が 8 進数 (0 〜 7) である場合、\nm は 8 進エスケープ値 _
nm に一致します。
'\nml n が 8 進数 (0 〜 3) で m と l が 8 進数 (0 〜 7) である場合、8 進エスケープ値 _
nml に一致します。
'\un n に一致します。n は、4 桁の 16 進数として表現された Unicode 文字を表します。 _
たとえば、'\u00A9' は著作権記号 (c) に一致します。
'(?:pattern) pattern に一致しますが、一致文字列は【記憶しません】（後では使用不可）。 _
この構文は、"or" 文字 (|) を使ってパターンの各部分を結合する場合に便利です｡ _
たとえば､ 'industr(?:y|ies)' は 'industry|industries' よりも効率的な正規表現です｡
'(?=pattern) pattern で指定した文字列が続く場合に一致と見なされます 【肯定先読み】。 _
一致文字列は【記憶しません】。 _
たとえば、'Windows (?=95|98|NT|2000)' は "Windows 2000" の "Windows" には一致 _
しますが、"Windows 3.1" の "Windows" には一致しません。 _
先読み処理は、確認した文字を処理済みとはしません。つまり、一致する検索文字列が _
見つかると､先読みされた文字列の直後からではなく､最後に一致した検索文字列の直後 _
から､次の検索が始まります｡
'(?!pattern) pattern で指定しない文字列が続く場合に一致と見なされます 【否定先読み】。 _
一致文字列は【記憶しません】。 _
たとえば、'Windows (?!95|98|NT|2000)' は "Windows 3.1" の "Windows" には一致 _
しますが、"Windows 2000" の "Windows" には一致しません。 _
先読み処理は、確認した文字を処理済みとはしません。つまり、一致する検索文字列が _
見つかると､先読みされた文字列の直後からではなく､最後に一致した検索文字列の直後 _
から､次の検索が始まります｡
Sub test()
Dim shtBase As Worksheet
Dim i As Integer
'ベースシート
Set shtBase = ActiveWorkbook.Worksheets(1)
'ベースシートをコピー
For i = 1 To 5
shtBase.Copy after:=shtBase
Next
'コピーしたシートの名前変更
With shtBase
For i = 1 To 5
.Parent.Worksheets(.Index + i).Name = NextShtName(.Name, .Parent)
Next
End With
End Sub
'シート名解決
Public Function NextShtName(BaseName As String, Wb As Workbook) As String
'BaseNameと同名シートが存在する時は、_1, _2, ... と、次に使用できる名前を返す
Dim Sht As Worksheet
Dim ShtName As String
Dim N As Long
N = -1
Do
N = N + 1
If N = 0 Then
ShtName = BaseName
Else
ShtName = BaseName & "_" & CStr(N)
End If
Set Sht = Nothing
On Error Resume Next
Set Sht = Wb.Worksheets(ShtName)
On Error GoTo 0
If Sht Is Nothing Then
NextShtName = ShtName
Exit Do
End If
Loop
End Function
Sub test()
Const S As String = "12ab5678xy1pppzABC9012"
Dim VV As Variant
Dim V As Variant
VV = nSplit(S, 5)
For Each V In VV
Debug.Print "*"; V; "*"
Next
End Sub
'文字列をN桁区切りにして配列(0から)に入れて返す
Private Function nSplit(ByVal D As String, Optional N As Integer = 5) As Variant
Dim V() As String
Dim U As Long
Dim i As Long
D = Trim$(D) '最後に付いている余分な空白文字への対応
U = (Len(D) - 1) \ N
ReDim V(0 To U)
For i = 0 To U
V(i) = Mid$(D, i * N + 1, N)
Next
nSplit = V
End Function
'２次元配列の後方カット
Private Function CutTail(VV As Variant, LastRow As Long) As Variant
If LastRow >= UBound(VV) Then
CutTail = VV
Exit Function
End If
Dim V As Variant
Dim i As Long, j As Long
ReDim V(LBound(VV) To LastRow, LBound(VV, 2) To UBound(VV, 2))
For i = LBound(VV) To LastRow
For j = LBound(VV, 2) To UBound(VV, 2)
V(i, j) = VV(i, j)
Next
Next
CutTail = V
End Function
'ワークシートの存在有無
Private Function ExistSheet(ShtName As String, Optional Book As Workbook) As Boolean
Dim Wb As Workbook
Dim Sht As Worksheet
Dim Flg As Boolean
Set Wb = Book
If Wb Is Nothing Then
Set Wb = ActiveWorkbook
End If
Flg = False
For Each Sht In Wb.Worksheets
If LCase(Sht.Name) = LCase(ShtName) Then
Flg = True
Exit For
End If
Next
ExistSheet = Flg
Set Wb = Nothing
End Function
===== ArgList.vbs =====
Option Explicit
const AppliName="ArgList"
dim Res
Res=ArgList
if varType(Res)<>vbBoolean then
msgbox Res & "件のリストを作成しました。",vbOkonly,AppliName
end if
function ArgList()
ArgList=False
dim Args, Arg, Fso, Ts, myPath, myDateTime
dim Ans, Msg, Ary, C, i, L, temp
set Args=WScript.Arguments
if Args.count=0 then
set Args=nothing
exit function
end if
Msg="名前のみにしますか？" & vbCrLf
Msg=Msg & vbCrLf
Msg=Msg & "「はい」＝＞名前のみ 「いいえ」＝＞フルパス"
Msg=Msg & vbCrLf
Ans=msgbox(Msg, vbYesNoCancel, "引数リスト作成")
if Ans=vbCancel then
set Args=nothing
exit function
end if
C=Args.count-1
redim Ary(C)
for i=0 to C
if Ans=vbYes then
temp=split(Args(i),"\")
Arg=temp(ubound(temp))
else
Arg=Args(i)
end if
Ary(i)=Arg
next
'L=len(WScript.ScriptName) 'このスクリプトと同じフォルダに作る場合
'myPath=WScript.ScriptFullName ' 〃
'myPath=left(myPath,len(myPath)-L) ' 〃
'作成先はデスクトップ固定
myPath = WScript.CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
myDateTime=replace(FormatDateTime(now,vbGeneralDate),"/","")
myDateTime=replace(myDateTime,":","")
myDateTime=replace(myDateTime," ","_")
myPath=myPath & myDateTime & ".txt"
set Fso=CreateObject("Scripting.FileSystemObject")
set Ts=Fso.OpenTextFile(myPath, 2, True)
Ary=join(Ary,vbCrLf)
Ts.write Ary
Ts.close
set Args=nothing
set Ts=nothing
set Fso=nothing
ArgList=C+1
end function
===== Sort.vbs =====
Option Explicit
test1
test2
test3
sub test1
Dim A
A = Array(4, 2, 1, 7, 8, 4, 2, 5, 9)
A = Csort(A)
Msgbox2 join(A,","),0,"",0
end sub
Sub test2()
Dim A
Dim Idx
Dim i
dim Ans
A = Array(6, 2, 4, 1, 7, 4, 9, 8, 4, 3, 7, 2, 5, 6, 4, 9, 1, 3, 2)
Idx = MsCombSortI(A)
Ans=""
For i = 0 To UBound(A)
Ans=Ans & "," & A(Idx(i))
Next
Ans=mid(Ans,2)
Msgbox2 Ans,0,"",0
End Sub
sub test3()
Dim A
Dim i
dim Ans
A = Array(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20)
A = RandomSort(A)
Ans=""
For i = 0 To UBound(A)
Ans=Ans & "," & A(i)
Next
Ans=mid(Ans,2)
Msgbox2 Ans,0,"",0
end sub
function RandomSort(byVal Ary)
dim U
dim R '乱数
dim Ndx
dim Ret
dim i
U=Ubound(Ary)
redim R(U)
Randomize
for i=0 to U
R(i)=Rnd
next
Ndx=MsCombSortI(R)
redim Ret(U)
for i=0 to U
Ret(i)=Ary(Ndx(i))
next
RandomSort=Ret
end function
Function Csort(ByVal Ary)
'昇順並べ替え、引数は１次元配列のみ可
Dim L, U
Dim i
Dim gap
Dim Temp
Dim F
L = 0
U = UBound(Ary)
gap = U - L
F = True
Do While gap > 1 Or F = True
gap = Int(gap / 1.3)
If gap = 9 Or gap = 10 Then
gap = 11
ElseIf gap < 1 Then
gap = 1
End If
F = False
For i = L To U - gap
If Ary(i) > Ary(i + gap) Then
Temp = Ary(i)
Ary(i) = Ary(i + gap)
Ary(i + gap) = Temp
F = True
End If
Next
Loop
Csort = Ary
End Function
Function MsCombSortI(Ary)
'昇順インデックスを返す
'配列引数Aryは１次元限定
Dim Idx
Dim L, U
Dim i
Dim gap
Dim Temp
Dim F
L = 0
U = UBound(Ary)
'インデックス初期設定
ReDim Idx(U)
For i = L To U
Idx(i) = i
Next
gap = U - L
F = True
'並べ替え
Do While gap > 1 Or F = True
gap = Int(gap / 1.3)
If gap = 9 Or gap = 10 Then
gap = 11
ElseIf gap < 1 Then
gap = 1
End If
F = False
For i = L To U - gap
If Ary(Idx(i)) > Ary(Idx(i + gap)) Then '降順時は <
Temp = Idx(i)
Idx(i) = Idx(i + gap)
Idx(i + gap) = Temp
F = True
ElseIf Ary(Idx(i)) = Ary(Idx(i + gap)) Then
If Idx(i) > Idx(i + gap) Then '昇順降順変更しても変更の必要なし
Temp = Idx(i)
Idx(i) = Idx(i + gap)
Idx(i + gap) = Temp
F = True
End If
End If
Next
Loop
MsCombSortI = Idx
End Function
Function Msgbox2(Msg, Style, Title, Time)
'時間指定なしは、Time=0として呼ぶ
'時間切れ時はTrue(-1)が返る
'×クリック時：Style=vbOKCancelなどで「ｷｬﾝｾﾙ」ボタンがある時 → vbCancel
' Style=vbOKOnlyなどで「OK」ボタンしか無い時 → vbOK
' 「OK」「ｷｬﾝｾﾙ」共に無い時は「×」は無効（淡色表示）
Dim WshShell
Set WshShell = WScript.CreateObject("WScript.Shell")
Msgbox2 = WshShell.Popup(Msg, Time, Title, Style)
Set WshShell = Nothing
End Function
Public Function Msgbox2(Optional Msg As String = "", Optional Style As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String = "Microsoft Excel", Optional T As Integer = 1) As VbMsgBoxResult
'時間切れ時はTrue(-1)が返る
'×クリック時：Style=vbOKCancelなどで「ｷｬﾝｾﾙ」ボタンがある時 → vbCancel
' Style=vbOKOnlyなどで「OK」ボタンしか無い時 → vbOK
' 「OK」「ｷｬﾝｾﾙ」共に無い時は「×」は無効（淡色表示）
Dim WshShell As Object
Set WshShell = CreateObject("WScript.Shell")
Msgbox2 = WshShell.Popup(Msg, T, Title, Style)
Set WshShell = Nothing
End Function
===== ReNameUnDo.vbs =====
Option Explicit
'機能：ReName.vbsで変更したファイル名を元に戻す。ex. 「ABCフォルダ」にて、ABC_xyz.jpg --> xyz.jpg
'使い方：エクスプローラでフォルダをこのスクリプトにD&Dする。複数可。
dim Args
dim fso, fld, fl, fls
dim fldPath, i, j
dim Ans, C
if WScript.Arguments.Count>=1 then
set Args=WScript.Arguments
Ans=msgbox("ファイル名からフォルダ名を削除し元に戻します。実行しますか?", vbYesNo)
if Ans=vbYes then
set fso=WScript.CreateObject("Scripting.FilesystemObject")
C=0
for i=0 to Args.Count-1
fldPath=Args(i)
set fld=fso.GetFolder(fldPath)
redim fls(fld.Files.Count-1)
j=0
for each fl in fld.Files
fls(j)=fl.Path
j=j+1
next
for j=0 to Ubound(fls)
set fl=fso.GetFile(fls(j))
'頭がフォルダ名_ならカットする
if left(fl.Name, len(fld.Name)+1)=(fld.Name & "_") then
fl.Name=mid(fl.Name, len(fld.Name)+2)
C=C+1
end if
next
next
set fl=nothing
set fls=nothing
set fld=nothing
set fso=nothing
msgbox cStr(C) & "個のファイル名を元に戻しました。", vbInformation
end if
set Args=nothing
end if
===== ReName.vbs =====
Option Explicit
'機能：ファイル名にそのフォルダ名を付加する。ex. ABCフォルダのxyz.jpg --> ABC_xyz.jpg
'使い方：エクスプローラでフォルダをこのスクリプトにD&Dする。複数可。
dim Args
dim fso, fld, fl, fls
dim fldPath, i, j
dim Ans, C
if WScript.Arguments.Count>=1 then
set Args=WScript.Arguments
Ans=msgbox("ファイル名をフォルダ名_ファイル名、に変更します。実行しますか?", vbYesNo)
if Ans=vbYes then
set fso=WScript.CreateObject("Scripting.FilesystemObject")
C=0
for i=0 to Args.Count-1
fldPath=Args(i)
set fld=fso.GetFolder(fldPath)
redim fls(fld.Files.Count-1)
j=0
for each fl in fld.Files
fls(j)=fl.Path '予め元のファイルパス（名前）を配列に取得しておくのがミソ。それをせずに下記でFor Eachで回すと無限ループになる場合がある。
j=j+1
next
for j=0 to Ubound(fls)
set fl=fso.GetFile(fls(j))
fl.Name=fld.Name & "_" & fl.Name
C=C+1
next
next
set fl=nothing
set fls=nothing
set fld=nothing
set fso=nothing
msgbox cStr(C) & "個のファイル名を変更しました。", vbInformation
end if
set Args=nothing
end if
===== CreateShortCut.vbs =====
Option Explicit
'機能
'ファイルへのショートカットを、そのフォルダ名_ファイル名.lnkとして作る。
'サブフォルダがあるフォルダを選んだ時
' 各々のサブフォルダ内のファイルへのショートカットを、選んだフォルダ内に作る
'サブフォルダが無いフォルダを選んだ時
' 選んだフォルダ内のファイルへのショートカットを、親フォルダ内に作る
'※つまり、一括で実行したい時はサブフォルダの親フォルダを選択し、個別に実行したい時はサブフォルダ１個を選択すれば良い
Dim Res
Dim WshShell
Dim Fso, Fld, SubFld, Fl
Dim C
'Res=SelectFolder("親フォルダを選択してください。", Null)
Res=WScript.Arguments(0)
If Res<>"" Then
Set WshShell=WScript.CreateObject("WScript.Shell")
Set Fso=WScript.CreateObject("Scripting.FileSystemObject")
Set Fld=Fso.GetFolder(Res)
C=0
If Fld.SubFolders.Count>=1 Then
'サブフォルダ内のファイルへのショートカットを作る
For Each SubFld In Fld.SubFolders
For Each Fl In SubFld.Files
MakeShortcut Fl.Path, Fld.Path & "\" & SubFld.Name & "_" & Fl.Name & ".lnk"
C=C+1
Next
Next
Else
'フォルダ内のファイルへのショートカットを親フォルダへ作る
For Each Fl In Fld.Files
MakeShortcut Fl.Path, Fld.ParentFolder.Path & "\" & Fld.Name & "_" & Fl.Name & ".lnk"
C=C+1
Next
End If
Msgbox cStr(C) & "個のショートカットを作成しました。", vbInformation
Set Fld=Nothing
Set Fso=Nothing
Set WshShell=Nothing
End If
Sub MakeShortcut(strSource, strDest)
Dim oLink
Set oLink=WshShell.CreateShortcut(strDest)
With oLink
.TargetPath=strSource
'.WindowStyle=1
'.Hotkey = "CTRL+SHIFT+F"
'.IconLocation="notepad.exe, 0"
'.Description = "Shortcut Script"
'.WorkingDirectory = strDesktop
.Save
End With
Set oLink=Nothing
End Sub
Sub test()
Dim Fld
Fld = SelectFolder("", Null)
'Fld = SelectFolder("選択してね", "c:\")
If Fld = "" Then
MsgBox "Cancel or Error", vbExclamation
Else
MsgBox Fld
End If
End Sub
'選択したフォルダのフルパスを返す。キャンセル又はエラーなら""を返す。
Function SelectFolder(Title, RootFolder) 'VBS用にフォルダ選択ダイアログを改良
Dim Shl 'Shell32.Shell
Dim Fld 'Folder
Dim strFld
Dim Ttl
If Title = "" Then
Ttl = "フォルダを選択してください。"
Else
Ttl = Title
End If
Set Shl = WScript.CreateObject("Shell.Application")
'1:コントロールパネルなどの余分なもの非表示 512:新規フォルダ作成ボタン非表示
If IsNull(RootFolder) Then
Set Fld = Shl.BrowseForFolder(0, Ttl, 1 + 512)
Else
Set Fld = Shl.BrowseForFolder(0, Ttl, 1 + 512, RootFolder)
End If
strFld = ""
If Not Fld Is Nothing Then
On Error Resume Next
strFld = Fld.Self.Path
If strFld = "" Then
strFld = Fld.Items.Item.Path
End If
On Error GoTo 0
End If
If InStr(strFld, "\") = 0 Then strFld = ""
SelectFolder = strFld
Set Fld = Nothing
Set Shl = Nothing
End Function
'使い方
'１．初期ページをIEで表示し、URLをコピーしておく
'２．SavePictures()を実行
'３．StartURLに上記URLをペースト
'４．EndNumberに最終番号入力
'５．「続けますか？」に対して「OK」クリック
'６．保存ダイアログで場所を指定して保存（場所の指定は一回目のみ）
'７．５に戻るので、必要なだけ繰り返す、途中でやめるときは「キャンセル」クリック
Sub SavePictures()
Dim IE As InternetExplorer
Dim urlStart As String
Dim numStart As Variant
Dim numEnd As Variant
Dim Head As String, Ichi As Long, Tail As String
Dim Ans As Variant
Dim i As Long
'スタートURL
urlStart = InputBox("StartURL(ex.http://.../abc001.jpg)?", "StartURL")
If urlStart = "" Then Exit Sub
'初期番号、頭、尻尾
numStart = GetLastNumber(urlStart, Ichi)
If numStart = "" Then Exit Sub
Head = Left(urlStart, Ichi - 1)
Tail = Mid(urlStart, Ichi + Len(numStart))
'最終番号
numEnd = InputBox("EndNumber(ex.60)?", "EndNumber")
If numEnd = "" Then Exit Sub
If Not IsNumeric(numEnd) Then Exit Sub
numEnd = Int(Val(numEnd))
Set IE = New InternetExplorer
With IE
For i = Val(numStart) To numEnd
Ans = MsgBox("続けますか？", vbOKCancel)
If Ans <> vbOK Then Exit For
.Visible = True
'ページを開き
.Navigate Head & Format(i, String(Len(numStart), "0")) & Tail
'開き切るのを待ち
IeWait IE
'名前をつけて保存ダイアログ表示（ヘルプではNotPRONPTUSERも可とあったが、実際にはうまく動作しなかった。）
.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER
.Visible = False
Next
.Quit
End With
Set IE = Nothing
End Sub
Sub test()
Const SS As String = "http://.../abc001.jpg"
Dim Num As String
Dim Ichi As Long
Num = GetLastNumber(SS, Ichi)
Debug.Print Num, Ichi
End Sub
'URLの最後の番号部分の情報を返す（ex.http://.../abc001.jpgの「001」）
Function GetLastNumber(Exp As String, Ichi As Long) As String
'S:「001」のスタート位置
Dim regEx As Object
Dim Match, Matches
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Pattern = "[\d]+"
.IgnoreCase = True
.Global = True
Set Matches = .Execute(Exp)
If Matches.Count >= 1 Then
Set Match = Matches(Matches.Count - 1)
Ichi = Match.FirstIndex + 1
GetLastNumber = Match.Value
End If
End With
Set regEx = Nothing
End Function
Sub IeWait(IE As InternetExplorer)
With IE
Do
If .Busy = True Then
Else
If .ReadyState = READYSTATE_COMPLETE Then
Exit Do
End If
End If
Application.Wait Now() + TimeSerial(0, 0, 1)
Loop
End With
End Sub
Sub test()
Const S As String = "1,2,3,5,8,10,11,12,13,15,17,19,20"
Dim V As Variant
Dim A As Variant
V = SumNumber(S)
For Each A In V
Debug.Print A
Next
End Sub
'昇順の連続・不連続番号(,区切り文字列)を、連番間をxx〜yyという形にして配列で返す
Function SumNumber(Num As String) As Variant
Dim S As Long
Dim E As Long
Dim Ary As Variant
Dim Flg As Boolean
Dim Ary2 As Variant
Dim C As Integer
Ary = Split(Num, ",")
S = LBound(Ary)
E = S
Do Until S > UBound(Ary)
E = E + 1
If E > UBound(Ary) Then
Flg = True
Else
If Val(Ary(E)) = Val(Ary(E - 1)) + 1 Then
Flg = False
Else
Flg = True
End If
End If
If Flg Then
C = C + 1
If C = 1 Then
ReDim Ary2(1 To C)
Else
ReDim Preserve Ary2(1 To C)
End If
If S = E - 1 Then
Ary2(C) = Ary(S)
Else
Ary2(C) = Ary(S) & "〜" & Ary(E - 1)
End If
S = E
End If
Loop
SumNumber = Ary2
End Function
===== 同名ブック起動vbs =====
Dim myPath
myPath=Wscript.ScriptFullName
myPath=Left(myPath, Len(myPath)-4)
Dim Exl
Set Exl=Nothing
On Error Resume Next
Set Exl=GetObject(,"Excel.Application")
On Error Goto 0
If Exl Is Nothing Then
Set Exl=CreateObject("Excel.Application")
End If
With Exl
.Visible=True
.Workbooks.Open myPath & ".xls"
End With
Set Exl=Nothing
===== Likee.vbs =====
Dim myPath
Dim Fls
Dim Msg
Dim i
myPath = CreateObject("WScript.Shell").specialfolders("mydocuments")
Fls = Dirs(myPath, "^c(.)*\.xls$")
If VarType(Fls) = vbBoolean Then
MsgBox "Not Found"
Else
On Error Resume Next
C = 0
For i = 0 To 3 'Ubound(Fls)
Msg = Msg & Fls(i) & vbCrLf
Next
On Error Goto 0
Msgbox Msg
End If
'指定フォルダ中の指定パターンのファイル名配列を返す
'（無効なフォルダ指定又はファイルが見つからない場合はFalse）
Private Function Dirs(Path, Patrn)
Dim FSO 'FileSystemObject
Dim Fld 'Folder
Dim Fl 'File
Dim Fls
Dim C
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fld = Nothing
On Error Resume Next
Set Fld = FSO.GetFolder(Path)
On Error GoTo 0
If Fld Is Nothing Then
Dirs = False
Set FSO = Nothing
Exit Function
End If
C = -1
For Each Fl In Fld.Files
If Likee(Fl.Name, Patrn, False) Then
C = C + 1
If C = 0 Then
ReDim Fls(0)
Else
ReDim Preserve Fls(C)
End If
Fls(C) = Fl.Name
End If
Next
If C = -1 Then
Dirs = False
Else
Dirs = Fls
End If
Set FSO = Nothing
Set Fld = Nothing
End Function
'VBAのLike演算子の代わり。一致：True、不一致：False
Private Function Likee(Moji, Patrn, MatchCase)
Dim regEx
Set regEx = New RegExp
With regEx
.Pattern = Patrn
.IgnoreCase = Not MatchCase
.Global = True
Likee = .Test(Moji)
End With
Set regEx = Nothing
End Function
===== Dirs.vbs =====
Dim myPath
Dim Fls
Dim Msg
Dim i
myPath = CreateObject("WScript.Shell").specialfolders("mydocuments")
Fls = Dirs(myPath, "^c(.)*\.xls$") 'Likeなら、c*.xls
If VarType(Fls) = vbBoolean Then
MsgBox "Not Found"
Else
On Error Resume Next
C = 0
For i = 0 To 4 'とりあえず５つ、全部ならUbound(Fls)まで
Msg = Msg & Fls(i) & vbCrLf
Next
On Error Goto 0
Msgbox Msg
End If
'指定フォルダ中の指定パターンのファイル名配列を返す
'（無効なフォルダ指定又はファイルが見つからない場合はFalse）
Private Function Dirs(Path, Patrn)
Dim FSO 'FileSystemObject
Dim Fld 'Folder
Dim Fl 'File
Dim Fls
Dim C
Dim regEx
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fld = Nothing
On Error Resume Next
Set Fld = FSO.GetFolder(Path)
On Error GoTo 0
If Fld Is Nothing Then
Dirs = False
Set FSO = Nothing
Exit Function
End If
Set regEx = New RegExp
With regEx
.Pattern = Patrn
.IgnoreCase = True
.Global = True
End With
C = -1
For Each Fl In Fld.Files
If regEx.Test(Fl.Name) Then
C = C + 1
If C = 0 Then
ReDim Fls(0)
Else
ReDim Preserve Fls(C)
End If
Fls(C) = Fl.Name
End If
Next
If C = -1 Then
Dirs = False
Else
Dirs = Fls
End If
Set regEx = Nothing
Set FSO = Nothing
Set Fld = Nothing
End Function
※使用方法：
０．シート上のボタンなどでFlgのONOFFを切り替える。
１．ONの状態の時、右クリックすると選択範囲がコピーされる。
２．そのコピー状態の時、別の場所を右クリックすると、コピーされている（破線範囲）と右クリックした範囲の値が交換される。
Option Explicit
Private Flg As Boolean
Private rngSource As Range
Private Sub CommandButton1_Click()
Flg = Not Flg
If Flg Then
Me.CommandButton1.Caption = "ON"
Else
Me.CommandButton1.Caption = "OFF"
End If
Set rngSource = Nothing
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
If Not Flg Then Exit Sub
Cancel = True
Dim S As Variant
Dim D As Variant
If Application.CutCopyMode = xlCopy Then
With rngSource
S = .Value
D = Target.Resize(.Rows.Count, .Columns.Count).Value
.Value = D
Target.Resize(.Rows.Count, .Columns.Count).Value = S
End With
Application.CutCopyMode = False
Else
Target.Copy
Set rngSource = Target
End If
End Sub
===== 公差.vbs =====
Dim Dat
Dim V
Dim A, B, C
Dim Ans
Dim Msg
Msg="径(mm) 公差上(μ) 公差下(μ) の順に入力してください" & Chr(10)
Msg=Msg & "(ex. 10 10 -15)"
Dat=""
Do
Dat=Inputbox(Msg,"中心値計算",Dat)
If Dat="" Then Exit Do
V=Split(Dat)
A=CDbl(V(0))
B=CDbl(V(1))/1000
C=CDbl(V(2))/1000
Ans=A+(B+C)/2
Msgbox "中心値(mm)=" & Ans
Loop
Sub Test()
If BookOpend("MyList.xls") Then
'処理
Else
Workbooks.Open "MyList.xls"
End If
End Sub
'指定ブックがオープン済みならTrue
Public Function BookOpend(Fn As String) As Boolean
Dim Wb As Workbook
Dim Flg As Boolean
For Each Wb In Workbooks
If LCase(Wb.Name) = LCase(Fn) Then
BookOpend = True
Exit Function
End If
Next
End Function
Sub Test
BookBackup ActiveWorkbook
End Sub
'ブックを同フォルダ下のBackupフォルダ内にyyyymmdd_hhmmss.xlsで保存
Private Sub BookBackup(Book As Workbook)
Dim BackupPath As String
Dim Na As String
BackupPath = Book.Path & "\Backup\"
If Dir(BackupPath, vbDirectory) = "" Then
MkDir BackupPath
End If
Na = Format$(Now(), "yyyymmdd_hhmmss") & ".xls"
Book.SaveCopyAs BackupPath & Na
End Sub
Sub test()
Dim myPath As String
Dim Fls As Variant
myPath = CreateObject("WScript.Shell").specialfolders("mydocuments")
Fls = Dirs(myPath, "c*[cd]*.xls")
If VarType(Fls) = vbBoolean Then
MsgBox "Not Found"
Else
ActiveCell.Resize(UBound(Fls)).Value = Application.WorksheetFunction.Transpose(Fls)
End If
End Sub
'指定フォルダ中の指定パターンのファイル名配列を返す
'（無効なフォルダ指定又はファイルが見つからない場合はFalse）
Function Dirs(Path As String, Pattern As String) As Variant
Dim Ptn As String
Dim FSO As Object 'FileSystemObject
Dim Fld As Object 'Folder
Dim Fl As Object 'File
Dim Fls As Variant
Dim C As Long
Ptn = LCase(Pattern)
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo Trap
Set Fld = FSO.GetFolder(Path)
On Error GoTo 0
For Each Fl In Fld.Files
If LCase(Fl.Name) Like Ptn Then
C = C + 1
If C = 1 Then
ReDim Fls(1 To 1)
Else
ReDim Preserve Fls(1 To C)
End If
Fls(C) = Fl.Name
End If
Next
If C = 0 Then
Dirs = False
Else
Dirs = Fls
End If
Set FSO = Nothing
Set Fld = Nothing
Exit Function
Trap:
Dirs = False
Set FSO = Nothing
Set Fld = Nothing
Exit Function
End Function
===== フルパス取得.vbs =====
Dim Exl
Dim rngDest
Dim Arg
Dim I
Set Exl=Nothing
Set Arg=WScript.Arguments
Set Exl=GetObject(,"Excel.Application")
With Exl
Set rngDest=.Worksheets(1).Range("A1")
For I=0 To Arg.Count - 1
rngDest.Value=Arg(I)
Set rngDest=rngDest.Offset(1)
Next
End With
Set Exl=Nothing
Set rngDest=Nothing
Sub test()
MsgBox AutoFilterCount(ActiveSheet)
End Sub
'オートフィルタ抽出結果数を返す
Function AutoFilterCount(Ws As Worksheet) As Long
Dim Sum As Long
Dim RR As Range
Dim Are As Range
Dim R As Range
On Error Resume Next
Set RR = Ws.AutoFilter.Range
On Error GoTo 0
If RR Is Nothing Then Exit Function
Set RR = RR.Columns(1)
Set RR = RR.SpecialCells(xlCellTypeVisible)
For Each Are In RR.Areas
For Each R In Are
Sum = Sum + R.Rows.Count
Next
Next
AutoFilterCount = Sum - 1
End Function
Sub 色で並べ替え2()
Dim RR As Range
Dim R As Range
Set RR = Range("A1")
Set RR = Range(RR, RR.End(xlDown))
Application.ScreenUpdating = False
RR.Offset(, 1).EntireColumn.Insert
For Each R In RR.Offset(, 1)
R.Value = R.Offset(, -1).Interior.ColorIndex
Next
RR.CurrentRegion.Sort RR.Offset(, 1).Item(1), xlAscending, header:=xlNo
RR.Offset(, 1).EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
'まず手動でオートフィルタ設定＆フィルタを掛けてから実行する
Sub test()
ManageFilter 1, ActiveSheet
MsgBox "フィルタを解除します。"
ActiveSheet.ShowAllData
MsgBox "先ほどのフィルタ設定状態を再現します。"
ManageFilter 2, ActiveSheet
End Sub
'AutoFilter設定状態の保存と復元
Public Sub ManageFilter(Mode As Integer, Ws As Worksheet)
'Mode 0:リセット 1:GetFilter 2:SetFilter
'トップテン指定などは無視、And,Orは可
'SetFilter時には、予めAutoFilterを設定してからコールすること
Dim Af As AutoFilter
Static Flts As Variant
Dim C As Integer
Dim i As Integer
Dim Cr1 As String
Dim Cr2 As String
Dim Ope As Long
If Mode = 0 Then
Flts = Empty
Exit Sub
End If
If Mode = 1 Then
Set Af = Nothing
On Error Resume Next
Set Af = Ws.AutoFilter
On Error GoTo 0
If Af Is Nothing Then
Flts = Empty
Exit Sub
End If
C = Af.Filters.Count
ReDim Flts(1 To C, 1 To 4)
For i = 1 To C
With Af.Filters(i)
Flts(i, 1) = .On
On Error Resume Next
Flts(i, 2) = .Criteria1
Flts(i, 3) = .Criteria2
Flts(i, 4) = .Operator
On Error GoTo 0
End With
Next
Set Af = Nothing
Exit Sub
End If
If Mode = 2 Then
If IsEmpty(Flts) Then Exit Sub
Set Af = Nothing
On Error Resume Next
Set Af = Ws.AutoFilter
On Error GoTo 0
If Af Is Nothing Then
Flts = Empty
Exit Sub
End If
C = Af.Filters.Count
If C <> UBound(Flts) Then
Flts = Empty
Set Af = Nothing
Exit Sub
End If
On Error Resume Next
Ws.ShowAllData
On Error GoTo 0
For i = 1 To C
If Flts(i, 1) Then
Ope = Flts(i, 4)
Cr1 = Flts(i, 2)
Cr2 = Flts(i, 3)
If Ope = 0 Then
Ws.AutoFilter.Range.AutoFilter i, Cr1
ElseIf Ope = xlAnd Or Ope = xlOr Then
Ws.AutoFilter.Range.AutoFilter i, Cr1, Ope, Cr2
End If
End If
Next
Set Af = Nothing
Exit Sub
End If
End Sub
Sub Test
CnvDT0 ActiveSheet
End Sub
'指定シートの特定列の８桁文字列を日付に変換する
Private Sub CnvDT0(Sht As Worksheet)
Dim RR As Range
Dim A As Variant
For Each A In Array("B", "C", "G", "H")
Set RR = Sht.Columns(A)
Set RR = Intersect(RR, Sht.UsedRange)
Set RR = Intersect(RR, RR.Offset(1))
CnvDT1 RR
Next
End Sub
'指定セル範囲の８桁文字列を日付に変え、書式は「yy/mm/dd」とする
Private Sub CnvDT1(RR As Range)
Dim R As Range
For Each R In RR.Cells
If Len(R.Value) >= 8 Then
On Error Resume Next
R.Value = ConvDate(R.Value)
On Error GoTo 0
End If
Next
RR.NumberFormatLocal = "yy/mm/dd"
End Sub
'8桁の文字列を日付に変換
Private Function ConvDate(DD As String) As Date
ConvDate = DateSerial(CInt(Left$(DD, 4)), CInt(Mid$(DD, 5, 2)), CInt(Mid$(DD, 7, 2)))
End Function
Sub CreateTestData()
'範囲を指定した整数を羅列した、４列のテキストファイルを作る。
Dim Fn As String
Dim N As Long
Dim i As Long
Const L2 As Long = 1
Const U2 As Long = 30
Const L3 As Long = 1
Const U3 As Long = 100
Const L4 As Long = 1
Const U4 As Long = 70
Fn = ThisWorkbook.Path & "\test.csv"
N = FreeFile(0)
Open Fn For Output As #N
Randomize
For i = 1 To 150000
Print #N, i; ","; Int((U2 - L2 + 1) * Rnd() + L2) _
; ","; Int((U3 - L3 + 1) * Rnd() + L3) _
; ","; Int((U4 - L4 + 1) * Rnd() + L4)
Next
Close #N
End Sub
'長いCSVファイルをシートに分けて読み込む
Sub ReadCsv4()
Const maxRow As Long = 65536
Const Fpath As String = "test.csv"
Dim VV As Variant 'CSVデータ全体(行分割)
Dim V As Variant '定数行毎のデータ(行列分割)
Dim A As Variant '列分割用
Dim Fso As Object 'FileSystemObject
Dim Txt As Object 'TextStream
Dim shtDest As Worksheet
Dim ShtCount As Long
Dim i As Long, j As Long, k As Long
Dim Lc As Long, Cc As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Txt = Fso.OpenTextFile(Fpath)
VV = Split(Txt.ReadAll, vbCrLf)
If VV(UBound(VV)) = "" Then
'最後が改行ならその部分をカットする
ReDim Preserve VV(UBound(VV) - 1)
End If
Txt.Close
Cc = UBound(Split(CStr(VV(0)), ",")) '列数
Application.ScreenUpdating = False
For i = 0 To UBound(VV) Step maxRow
If UBound(VV) - i + 1 < maxRow Then
Lc = UBound(VV) - i + 1 - 1
Else
Lc = maxRow - 1
End If
ReDim V(0 To Lc, 0 To Cc)
'定数行以内で行列に分割
For j = 0 To Lc
A = Split(CStr(VV(i + j)), ",")
For k = 0 To Cc
V(j, k) = A(k)
Next
Next
'シートへ書き込み
ShtCount = ShtCount + 1
If ShtCount = 1 Then
Set shtDest = Workbooks.Add.Worksheets(1)
Else
On Error GoTo AddSheet
Set shtDest = ActiveWorkbook.Worksheets(ShtCount)
On Error GoTo 0
End If
shtDest.Range("A1").Resize(Lc + 1, Cc + 1).Value = V
Next
Application.ScreenUpdating = True
Set Txt = Nothing
Set Fso = Nothing
Exit Sub
'足りないシートの補充
AddSheet:
With ActiveWorkbook
Set shtDest = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
End With
Resume Next
End Sub
'長いCSVファイルをシートに分けて読み込む（プログレスバー付）
Sub ReadCsv4withProgress()
Const maxRow As Long = 65536
Const Fpath As String = "test.csv"
Dim VV As Variant 'CSVデータ全体(行分割)
Dim V As Variant '定数行毎のデータ(行列分割)
Dim A As Variant '列分割用
Dim Fso As Object 'FileSystemObject
Dim Txt As Object 'TextStream
Dim shtDest As Worksheet
Dim ShtCount As Long
Dim i As Long, j As Long, k As Long
Dim Lc As Long, Cc As Long
Dim myBar As cProgress
Set myBar = New cProgress
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Txt = Fso.OpenTextFile(Fpath)
VV = Split(Txt.ReadAll, vbCrLf)
If VV(UBound(VV)) = "" Then
'最後が改行ならその部分をカットする
ReDim Preserve VV(UBound(VV) - 1)
End If
Txt.Close
With myBar
.Max = UBound(VV)
.Start
.Value = 0
End With
Cc = UBound(Split(CStr(VV(0)), ",")) '列数
Application.ScreenUpdating = False
For i = 0 To UBound(VV) Step maxRow
If UBound(VV) - i + 1 < maxRow Then
Lc = UBound(VV) - i + 1 - 1
Else
Lc = maxRow - 1
End If
ReDim V(0 To Lc, 0 To Cc)
'定数行以内で行列に分割
For j = 0 To Lc
A = Split(CStr(VV(i + j)), ",")
For k = 0 To Cc
V(j, k) = A(k)
Next
If (i + j) Mod 1000 = 0 Then
myBar.Value = i + j
End If
Next
'シートへ書き込み
ShtCount = ShtCount + 1
If ShtCount = 1 Then
Set shtDest = Workbooks.Add.Worksheets(1)
Else
On Error GoTo AddSheet
Set shtDest = ActiveWorkbook.Worksheets(ShtCount)
On Error GoTo 0
End If
shtDest.Range("A1").Resize(Lc + 1, Cc + 1).Value = V
Next
Application.ScreenUpdating = True
Set Txt = Nothing
Set Fso = Nothing
Set myBar = Nothing
Exit Sub
'足りないシートの補充
AddSheet:
With ActiveWorkbook
Set shtDest = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
End With
Resume Next
End Sub
Sub CreateNumber()
Dim RR As Range
Dim R As Range
Dim C As Long
Set RR = Range("A1")
Set RR = Range(RR, Cells(Rows.Count, RR.Column).End(xlUp))
Set RR = RR.SpecialCells(xlCellTypeVisible)
C = 1
For Each R In RR.Cells
R.Value = C
C = C + 1
Next
End Sub
'使用範囲の１列目に対して連番（こちらの方が実用的か？）
Sub CreateNumber2()
Dim RR As Range
Dim R As Range
Dim C As Long
Set RR = ActiveSheet.UsedRange.Columns(1)
Set RR = RR.SpecialCells(xlCellTypeVisible)
C = 1
For Each R In RR.Cells
R.Value = C
C = C + 1
Next
End Sub
'アクティブブックの各シートをCSVファイルとして作成する
Sub CreateCSV()
Dim Sht As Worksheet
Dim myPath As String
myPath = ActiveWorkbook.Path & "\"
'myPath = ThisWorkbook.Path & "\"
For Each Sht In ActiveWorkbook.Worksheets
Sht.Copy
With ActiveWorkbook
.SaveAs myPath & Sht.Name & ".csv", FileFormat:=xlCSV
.Close False
End With
Next
End Sub
'※重要な注意：掲示板によっては頭のインデント以外の部分も半角空白が１つに縮められる場合があるので、そこは良く確認してください。
'クリップボード内の半角スペースインデントを全角スペースに置き換える
'(Microsoft Forms x.x Object Libraryへの参照設定が必要)
Sub ConvCode()
Const Before As String = " " 'ここは半角空白４つ
Const After As String = " "
Dim Doj As DataObject
Dim V As Variant
Dim A As Variant
Dim Head As String
Dim i As Integer
Set Doj = New DataObject
With Doj
.GetFromClipboard
If .GetFormat(1) Then
V = Split(.GetText, vbCrLf)
For Each A In V
Head = Left$(A, Len(A) - Len(LTrim$(A)))
Head = Replace(Head, Before, After)
V(i) = Head & LTrim$(A)
i = i + 1
Next
V = join(V, vbCrLf)
.SetText V
.PutInClipboard
End If
End With
Set Doj = Nothing
End Sub
Sub オートフィルタをかけて必要列のみをコピー()
Dim RR As Range
'操作対象範囲
Set RR = Worksheets(1).AutoFilter.Range
'オートフィルタの対象列とフィルタ条件
RR.AutoFilter 3, "=2"
'必要列のみ抽出
Set RR = Intersect(RR, RR.Worksheet.Range("A:A,D:D,E:E"))
Set RR = RR.SpecialCells(xlCellTypeVisible)
'コピー＆貼り付け
RR.Copy Worksheets(2).Range("C10")
'すべて表示、に戻しておく
RR.Worksheet.ShowAllData
End Sub
Sub ShowStatus()
Dim V As Variant
Dim i As Integer
'最後の値として最初の値を入れてあるのがミソ
V = Array("出社", "休憩", "食事", "帰宅", "出社")
With Range("A1")
For i = 0 To UBound(V) - 1
'現在の値が見つかれば、配列の次の値を設定
If .Value = V(i) Then
.Value = V(i + 1)
Exit Sub
End If
Next
'見つからなければ、配列の最初の値を設定
.Value = V(0)
End With
End Sub
'複数列の最終行への参照を返す(最下行の非表示対応、但しフィルタによる非表示は非対応)
Public Function GetLastRange(ByVal RR As Range) As Range
Dim rngFind As Range
Set RR = RR.EntireColumn
Set rngFind = RR.Find(what:="*", LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngFind Is Nothing Then
Set GetLastRange = RR.Rows(1)
Else
Set GetLastRange = Intersect(RR, rngFind.EntireRow)
End If
End Function
'1 a 1 a、b
'1 b ⇒ 2 c
'2 c 3 d、e、f
'3 d
'3 e
'3 f
'同一コードのデータを結合する
Sub Summary()
Dim R As Range
Dim rngDest As Range
Dim Code As String
Dim SS As String
Set R = Range("A1") 'コードの先頭セル
Set rngDest = Range("D1") '書き込み先先頭セル
Do Until R.Value = ""
If Code = "" Then
Code = R.Value
SS = R.Offset(, 1).Value
ElseIf R.Value = Code Then
SS = SS & "、" & R.Offset(, 1).Value
Else
rngDest.Value = Code
rngDest.Offset(, 1).Value = SS
Set rngDest = rngDest.Offset(1)
Code = R.Value
SS = R.Offset(, 1).Value
End If
Set R = R.Offset(1)
Loop
If Code <> "" Then
rngDest.Value = Code
rngDest.Offset(, 1).Value = SS
End If
End Sub
===== 標準モジュール ====
Sub test()
Dim myBar As cProgress
Dim myPath As String
Dim Fname As String
Dim Cmax As Long
'マイドキュメント
myPath = CreateObject("Wscript.Shell").SpecialFolders("MyDocuments") & "\"
'ファイル数を予めカウント
Fname = Dir(myPath & "b*.xls")
Do Until Fname = ""
Cmax = Cmax + 1
Fname = Dir()
Loop
If Cmax = 0 Then Exit Sub
'プログレスバー準備
Set myBar = New cProgress
With myBar
.Style = plBarAndPercentAndRestTime
.Min = 0
.Max = Cmax
.Msg = "処理しています..."
.Start '残り時間(RestTime)表示時は必須
End With
'処理（開いて閉じるだけ）
Application.ScreenUpdating = False
Fname = Dir(myPath & "b*.xls")
Do Until Fname = ""
With Workbooks.Open(myPath & Fname, ReadOnly:=True)
myBar.Value = myBar.Value + 1 'プログレスバー更新
Application.Wait Now + TimeSerial(0, 0, 2)
.Close False
End With
Fname = Dir()
Loop
Application.ScreenUpdating = True
Set myBar = Nothing
End Sub
===== cProgress クラスモジュール =====
Option Explicit
Public Enum plStyle
plBarOnly = 0 'バーのみ
plBarAndPercent = 1 'バー+%
plBarAndRestTime = 2 'バー+残り時間
plBarAndPercentAndRestTime = 3 'バー+%+残り時間
End Enum
Private maxLen As Long 'プログレスバーの文字列長
Private StartTime As Date '実行開始時間
Private MinVal As Long '最小値
Private MaxVal As Long '最大値
Private myVal As Long '現在値
Private myStyle As plStyle '表示の仕方
Private myDisplayStatusBar As Boolean 'ステータスバーの初期状態
Private myMsg As String 'メッセージ表示
Public Property Let Length(L As Long)
maxLen = L
End Property
Public Sub Start()
StartTime = Now
End Sub
Public Property Let Min(MinValue As Long)
MinVal = MinValue
End Property
Public Property Get Min() As Long
Min = MinVal
End Property
Public Property Let Max(MaxValue As Long)
MaxVal = MaxValue
End Property
Public Property Get Max() As Long
Max = MaxVal
End Property
Public Property Let Style(V As plStyle)
If V >= 0 And V <= 3 Then
myStyle = V
End If
End Property
Public Property Let Msg(Message As String)
myMsg = Message
If myMsg <> "" Then
If (Left$(myMsg, 1) <> " ") And (Left$(myMsg, 1) <> " ") Then
myMsg = " " & myMsg
End If
End If
End Property
Private Sub Class_Initialize()
maxLen = 20
MinVal = 0
MaxVal = 100
myVal = 0
myStyle = plBarAndPercent
myDisplayStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
myMsg = ""
Start
End Sub
Private Sub Class_Terminate()
Application.StatusBar = False
Application.DisplayStatusBar = myDisplayStatusBar
End Sub
Public Property Let Value(V As Long)
Dim P As Long
Dim Zan As Date
Dim Bar As String
Dim Lvl As Long
If MaxVal <= MinVal Then MaxVal = MinVal + 1 '不正設定対策
If V < MinVal Then
myVal = MinVal
ElseIf V > MaxVal Then
myVal = MaxVal
Else
myVal = V
End If
P = (myVal - MinVal) / (MaxVal - MinVal) * 100
If P > 0 Then
Zan = (Now - StartTime) / (P / 100) '予想される総処理時間
Zan = Zan * (1 - (P / 100)) '残時間
End If
Bar = String$(maxLen, "□")
If P > 0 Then
Lvl = maxLen * (P / 100)
Mid$(Bar, 1, Lvl) = String$(Lvl, "■")
Select Case myStyle
Case plBarAndPercent
Bar = Bar & P & "%"
Case plBarAndRestTime
Bar = Bar & "残り" & Zan
Case plBarAndPercentAndRestTime
Bar = Bar & P & "% 残り" & Zan
End Select
End If
Application.StatusBar = Bar & myMsg
End Property
Public Property Get Value() As Long
Value = myVal
End Property
Sub Test
GetLastRange(Selection).Select
End Sub
'複数列の最終行への参照を返す
Public Function GetLastRange(RR As Range) As Range
Dim rngLast As Range
Dim A As Long, B As Long
Dim R As Range
Dim E As Range
A = RR.Column
B = A + RR.Columns.Count - 1
With RR.Worksheet
Set rngLast = .Range(.Cells(.Rows.Count, A), .Cells(.Rows.Count, B))
End With
For Each R In rngLast.Cells
Set R = R.End(xlUp)
If E Is Nothing Then Set E = R
If R.Row > E.Row Then
Set E = R
End If
Next
Set GetLastRange = Intersect(E.EntireRow, rngLast.EntireColumn)
End Function
Sub test()
'B,C,D列の内の最下行を選択する
Dim R As Range
Dim E As Range
For Each R In Range("B65536:D65536")
Set R = R.End(xlUp)
If E Is Nothing Then Set E = R
If R.Row > E.Row Then
Set E = R
End If
Next
E.Select
End Sub
===== ThisWorkbook =====
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars("ユーザー設定 1").Visible = False
End Sub
Private Sub Workbook_Open()
Dim M As String
Dim V As Variant
Dim i As Integer
With Application.CommandBars("ユーザー設定 1")
.Visible = True
For i = 1 To .Controls.Count
With .Controls(i)
M = .OnAction
V = Split(M, "!")
M = V(UBound(V))
.OnAction = M
End With
Next
End With
End Sub
Sub FindSample()
Dim RR As Range
Dim F As Range
Dim FirstAddress As String
Set RR = Range("A1:J20")
With RR
Set F = .Find(what:="aaa", after:=.Cells(.Count))
If F Is Nothing Then
MsgBox "Not Found!", vbExclamation
Exit Sub
End If
FirstAddress = F.Address
Do
'処理
Debug.Print F.Address
Set F = .FindNext(F)
Loop Until F.Address = FirstAddress
End With
End Sub
Sub 選択範囲を画像ファイルに保存()
With Selection
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With ActiveCell.Worksheet.ChartObjects.Add(.Left, .Top, .Width, .Height)
With .Chart
.Paste
.Export "test.gif", "gif"
End With
.Delete
End With
End With
End Sub
Sub RenameFiles()
Dim myPath As String
Dim Fname As String
Dim Fnames As Variant
Dim C As Integer
Dim i As Integer
Const Head As String = "d-"
myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
myPath = myPath & "\ゆうこりんTemp4\"
Fname = Dir(myPath & "*.jp*")
Do Until Fname = ""
If LCase(Fname) Like "*.jpg" Or LCase(Fname) Like "*.jpeg" Then
C = C + 1
If C = 1 Then
ReDim Fnames(1 To 1)
Else
ReDim Preserve Fnames(1 To C)
End If
Fnames(C) = Fname
End If
Fname = Dir()
Loop
For i = 1 To C
Name myPath & Fnames(i) As myPath & Head & Fnames(i)
Next
End Sub
Sub 一括印刷()
Dim RR As Range
Dim R As Range
Dim sht印刷 As Worksheet
Dim rng住所 As Range
Dim wbPrint As Workbook
'住所一覧の在るセル範囲
Set RR = Worksheets("住所一覧").Range("A1")
Set RR = Range(RR, RR.End(xlDown))
'印刷様式シート
Set sht印刷 = Worksheets("封筒印刷")
'そのシートの中の住所記入セル
Set rng住所 = sht印刷.Range("A1")
'印刷用の一時的なブックを、各住所を書き込んだシートをコピーして作成
For Each R In RR
rng住所.Value = R.Value
If wbPrint Is Nothing Then
sht印刷.Copy
Set wbPrint = ActiveWorkbook
Else
sht印刷.Copy after:=wbPrint.Sheets(wbPrint.Sheets.Count)
End If
Next
'印刷用の一時的なブックを印刷して、保存せずに終了
wbPrint.Sheets.PrintPreview
wbPrint.Close False
End Sub
Sub ブックを開かずに値を取得()
Const myPath As String = "c:\my documents"
Const BookName As String = "book2.xls"
Const SheetName As String = "Sheet1"
Const myAddress As String = "$A:$A"
Dim myFormula As String
myFormula = "=SUM('" & myPath & "\[" & BookName & "]" _
& SheetName & "'!" & myAddress & ")"
Range("A1").Formula = myFormula
Range("A1").Value = Range("A1").Value
End Sub
'Rangeを受け、重複の無い一次元配列を返す
Public Function GetSummary(RR As Range) As Variant
'返す配列の添え字下限は0
Dim R As Range
Dim Dic As Object
Dim K As String
Dim V As Variant
Set Dic = CreateObject("Scripting.Dictionary")
For Each R In RR.Cells
K = R.Value
If K <> "" Then
Dic(K) = Empty
End If
Next
V = Dic.keys
Set Dic = Nothing
GetSummary = Csort(V) '並べ替え不要ならCsort()は不要
End Function
Sub 列折り返し4()
Const 行数 As Long = 50
Const 列数 As Long = 4
Dim RR As Range
Dim rngDest As Range
Dim j As Long
Set RR = Worksheets("Sheet1").Range("A1")
Set RR = RR.Resize(行数, 2)
Set rngDest = Worksheets("Sheet2").Range("A1")
j = 0
Do Until RR.Cells(1).Value = ""
j = j + 1
If j > 列数 Then
j = 1
Set rngDest = rngDest.Offset(行数)
End If
RR.Copy rngDest.Offset(, (j - 1) * 2)
Set RR = RR.Offset(行数)
Loop
End Sub
Sub test()
Dim a As String, b As String
a = "123" & vbTab & "あ" & vbTab & "１２３4" & vbTab & "END"
b = Tab2Spc(a)
ActiveCell.Value = a 'ActiveCellと
ActiveCell.Offset(1).Value = b '一つ下のセルの値をメモ帳にコピペして結果を確認して下さい
End Sub
Function Tab2Spc(SS As String) As String
Const TabLen As Integer = 8
Dim i As Integer
Dim S As String
Dim S2 As String
For i = 1 To Len(SS)
S = Mid$(SS, i, 1)
If S = vbTab Then
S2 = S2 & Space$(TabLen - LenB(StrConv(S2, vbFromUnicode)) Mod TabLen)
Else
S2 = S2 & S
End If
Next
Tab2Spc = S2
End Function
Private Function CellIndex(myRange As Range) As Long
'特定セル範囲内における、ActiveCellのIndexを返す
Dim R As Long, C As Long
If Intersect(myRange, ActiveCell) Is Nothing Then
CellIndex = 0
Exit Function
End If
With myRange
R = ActiveCell.Row - .Row + 1
C = ActiveCell.Column - .Column + 1
CellIndex = (R - 1) * .Columns.Count + C
End With
End Function
===== ThisWorkbookモジュール =====
Option Explicit
Private WithEvents ExlApp As Application
Private Const MenuCaption As String = "印"
Private Sub ExlApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
If Marker = "" Then Exit Sub
Dim R As Range
For Each R In Target
If R.Value <> Marker Then
R.Value = Marker
Else
R.ClearContents
End If
Next
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set ExlApp = Nothing
DeleteMenu
End Sub
Private Sub Workbook_Open()
Set ExlApp = Application
AddMenu
End Sub
Private Sub AddMenu()
Dim myMenu As CommandBarPopup
Set myMenu = Application.CommandBars("WorkSheet Menu Bar").Controls.Add(Type:=msoControlPopup, temporary:=True)
myMenu.Caption = MenuCaption
With myMenu.CommandBar.Controls.Add(Type:=msoControlButton)
.Caption = "○"
.OnAction = "SetMarker"
End With
With myMenu.CommandBar.Controls.Add(Type:=msoControlButton)
.Caption = "◎"
.OnAction = "SetMarker"
End With
With myMenu.CommandBar.Controls.Add(Type:=msoControlButton)
.Caption = "△"
.OnAction = "SetMarker"
End With
Set myMenu = Nothing
End Sub
Private Sub DeleteMenu()
On Error Resume Next
Application.CommandBars("WorkSheet Menu Bar").Controls(MenuCaption).Delete
On Error GoTo 0
End Sub
===== 標準モジュール =====
Option Explicit
Public Marker As String
Private Sub SetMarker()
Dim Button As CommandBarButton
Dim B As CommandBarButton
On Error Resume Next
Set Button = Application.CommandBars.ActionControl
On Error GoTo 0
If Button Is Nothing Then
Marker = ""
Else
With Button
If .State = msoButtonDown Then
.State = msoButtonUp
Marker = ""
Else
For Each B In .Parent.Controls
B.State = msoButtonUp
Next
.State = msoButtonDown
Marker = .Caption
End If
End With
End If
End Sub
===== DragDrop.vbs =====
Dim Exl
Dim Arg
Dim I
Set Exl=Nothing
Set Arg=WScript.Arguments
On Error Resume Next
Set Exl=GetObject(,"Excel.Application")
On Error Goto 0
If Exl Is Nothing Then
Set Exl=CreateObject("Excel.Application") '新規インスタンスの時はアドインが有効にならない(TT)
End If
With Exl
.Visible=True
For I=0 To Arg.Count - 1
.Workbooks.Open Arg(I)
Next
End With
Set Exl=Nothing
===== BookOpen.vbs =====
Dim Exl
Set Exl=Nothing
On Error Resume Next
Set Exl=GetObject(,"Excel.Application")
On Error Goto 0
If Exl Is Nothing Then
Set Exl=CreateObject("Excel.Application") '新規インスタンスの時はアドインがLoadされない(TT)
End If
With Exl
.Visible=True
.Workbooks.Open "test.xls"
End With
Set Exl=Nothing
Sub 矢印以外の直線削除()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
If Shp.Type = msoLine Then
If Shp.Line.EndArrowheadStyle = msoArrowheadNone _
And Shp.Line.BeginArrowheadStyle = msoArrowheadNone Then
'Shp.Delete
Debug.Print Shp.Name
End If
End If
Next
End Sub
===== Test.vbs =====
set Exl=CreateObject("Excel.Application")
With Exl
set Wb=.Workbooks.Open("Book1.xls")
Wb.ShowForm
.Visible=True 'Formクローズ後Excel.Quitなら不要
End With
set Wb=Nothing
set Exl=Nothing
===== Book1.xls ThisWorkbook =====
Public Sub ShowForm()
UserForm1.Show
End Sub
===== Book1.xls UserForm1 =====
Private Sub CommandButton1_Click()
Unload Me
Application.Quit 'この行が無い時は上記 .Visible=Trueは必須。無いとインスタンスが残ってしまう。
End Sub
===== UserForm1 =====
新規ユーザーフォームUserForm1を手作業で挿入する、デザインやコード記述はいっさい不要
===== 標準モジュール =====
Sub クラスをそのまま利用()
Dim myList As cListBox
Dim myArray As Variant
myArray = Array("a", "b", "c", "d", "e")
Set myList = New cListBox
With myList
.Title = "選択してください。"
.List = myArray
.Index = 2
.ShowForm
If .Status <> vbOK Then
MsgBox "キャンセルしました。"
Else
MsgBox myArray(.Index)
End If
End With
Set myList = Nothing
End Sub
Sub 関数を通して利用()
Dim L As Variant
Dim A As Integer
L = Array("a", "b", "c", "d", "e")
A = Lst(L, "選択してください。")
If A = -1 Then
MsgBox "キャンセルまたは未選択"
Else
MsgBox L(A)
End If
End Sub
Function Lst(L As Variant, T As String) As Integer
Dim myList As cListBox
Set myList = New cListBox
With myList
.Title = T
.List = L
.ShowForm
If .Status <> vbOK Then
Lst = -1
Else
Lst = .Index
End If
End With
Set myList = Nothing
End Function
===== クラスモジュール(cListBox) =====
Option Explicit
Private UForm As UserForm1
Private WithEvents lstListBox As MSForms.ListBox
Private Idx As Integer
Private WithEvents cmdOK As MSForms.CommandButton
Private WithEvents cmdCancel As MSForms.CommandButton
Private ClickedButton As Integer
Private Sub Class_Initialize()
Set UForm = New UserForm1
Set lstListBox = UForm.Controls.Add("Forms.ListBox.1")
lstListBox.Move 20, 20, 100, 120
Idx = -1
Set cmdOK = UForm.Controls.Add("Forms.CommandButton.1")
With cmdOK
.Move 170, 20, 50, 20
.Caption = "OK"
.Accelerator = "O"
.Default = True
End With
Set cmdCancel = UForm.Controls.Add("Forms.CommandButton.1")
With cmdCancel
.Move 170, 50, 50, 20
.Caption = "Cancel"
.Accelerator = "C"
.Cancel = True
End With
ClickedButton = vbCancel
End Sub
Private Sub Class_Terminate()
Set lstListBox = Nothing
Set cmdOK = Nothing
Set cmdCancel = Nothing
Set UForm = Nothing
End Sub
Public Property Get Index() As Integer
Index = Idx
End Property
Public Property Let Index(Ndx As Integer)
Idx = Ndx
On Error Resume Next 'ListとIndexどちらを先に設定しても良いように
lstListBox.ListIndex = Idx
On Error GoTo 0
End Property
Public Property Get Status() As Integer
Status = ClickedButton
End Property
Public Property Let List(L As Variant)
Dim A As Variant
With lstListBox
.Clear
For Each A In L
.AddItem A
Next
.ListIndex = Idx
End With
End Property
Public Sub ShowForm()
UForm.Show
End Sub
Public Property Let Title(Ttl As String)
UForm.Caption = Ttl
End Property
Private Sub cmdCancel_Click()
ClickedButton = vbCancel
Unload UForm
End Sub
Private Sub cmdOK_Click()
ClickedButton = vbOK
Unload UForm
End Sub
Private Sub lstListBox_Click()
Idx = lstListBox.ListIndex
End Sub
Option Explicit
Private R As Long
Sub myList()
Dim Fso As FileSystemObject
Dim Fl As Folder
Dim C As Integer
Set Fso = New FileSystemObject
R = 1: C = 1
Set Fl = Fso.GetFolder("c:\my documents")
Application.ScreenUpdating = False
FolderList Fl, C
Application.ScreenUpdating = True
Set Fl = Nothing
Set Fso = Nothing
End Sub
Private Sub FolderList(PFl As Folder, C As Integer)
Dim Fls As Folders
Dim Fl As Folder
Cells(R, C).Value = PFl.Name & " --- " & _
PFl.DateLastModified & " --- " _
& Format(PFl.Size, "#,#")
R = R + 1
Set Fls = PFl.SubFolders
If Fls.Count > 0 Then
For Each Fl In Fls
FolderList Fl, C + 1
Next
End If
End Sub
Sub CSV作成()
'Sheet1,2,3を横に連結して出力
Dim myPath As String
Dim N As Integer
Dim mySheets As Variant
Dim maxRow As Long, maxColumn As Long
Dim i As Long, j As Long, k As Long
Dim Flg As Boolean
mySheets = Array("Sheet1", "Sheet2", "Sheet3")
With Worksheets(mySheets(0)).UsedRange
maxRow = .Rows.Count
maxColumn = .Columns.Count
End With
myPath = ActiveWorkbook.Path & "\Test.csv"
N = FreeFile
Open myPath For Output As #N
For i = 1 To maxRow
Flg = True
For j = 0 To UBound(mySheets)
With Worksheets(mySheets(j))
For k = 1 To maxColumn
If Flg Then
Print #N, .Cells(i, k).Value;
Else
Print #N, ","; .Cells(i, k).Value;
End If
Flg = False
Next k
End With
Next j
Print #N, ""
Next i
Close #N
End Sub
1
2
3
4
5
6
7
8
9
10
↓ （2行3列の場合）
1 3 5
2 4 6
7 9
8 10
Sub 列折り返し1() '素直な思考のアルゴリズム（元データのループを中心にして、行・列・ページをインクリメント）
'1列のデータを指定行、指定列で折り返す
Dim VV As Variant
Dim V2 As Variant
Dim RR As Range
Dim rngDest As Range
Dim C As Long
Dim ii As Long
Dim i As Long, j As Long, P As Long
Const 指定行 As Integer = 57
Const 指定列 As Integer = 6
Set RR = Range("A1")
Set RR = Range(RR, RR.End(xlDown))
VV = RR.Value
C = 指定行 * 指定列
i = UBound(VV) \ C
If (UBound(VV) Mod C) <> 0 Then
i = i + 1
End If
i = i * 指定行
ReDim V2(1 To i, 1 To 指定列)
i = 0: j = 1: P = 1
For ii = 1 To UBound(VV)
i = i + 1
If i > 指定行 Then
i = 1
j = j + 1
If j > 指定列 Then
j = 1
P = P + 1
End If
End If
V2((P - 1) * 指定行 + i, j) = VV(ii, 1)
Next
Set rngDest = Worksheets.Add.Range("A1")
rngDest.Resize(UBound(V2), UBound(V2, 2)).Value = V2
End Sub
Sub 列折り返し2() '拡張しやすい形のアルゴリズム（ページ・列・行の階層ループの中で元データをインクリメント）
'1列のデータを指定行、指定列で折り返す
Dim VV As Variant
Dim V2 As Variant
Dim RR As Range
Dim rngDest As Range
Dim C As Long
Dim ii As Long
Dim i As Integer, j As Integer
Dim Pmax As Integer, P As Integer
Const 指定行 As Integer = 57
Const 指定列 As Integer = 6
Set RR = Range("A1")
Set RR = Range(RR, RR.End(xlDown))
VV = RR.Value
C = 指定行 * 指定列
Pmax = UBound(VV) \ C
If (UBound(VV) Mod C) <> 0 Then
Pmax = Pmax + 1
End If
ReDim V2(1 To Pmax * 指定行, 1 To 指定列)
i = 1: j = 1: P = 1: ii = 1
Do While P <= Pmax And ii <= UBound(VV)
Do While j <= 指定列 And ii <= UBound(VV)
Do While i <= 指定行 And ii <= UBound(VV)
V2((P - 1) * 指定行 + i, j) = VV(ii, 1)
i = i + 1
ii = ii + 1
Loop
i = 1
j = j + 1
Loop
j = 1
P = P + 1
Loop
Set rngDest = Worksheets.Add.Range("A1")
rngDest.Resize(UBound(V2), UBound(V2, 2)).Value = V2
End Sub
Sub 列折り返し3() '列折り返し2()の拡張版、元データ列数が任意数に対応
'3列で対のデータを指定行、指定列(倍数)で折り返す
Dim VV As Variant
Dim V2 As Variant
Dim RR As Range
Dim rngDest As Range
Dim C As Long
Dim ii As Long
Dim i As Integer, j As Integer, k As Integer
Dim Pmax As Integer, P As Integer
Const 元列数 As Integer = 3
Const 指定行 As Integer = 57
Const 指定列 As Integer = 4
Set RR = Range("A1")
Set RR = Range(RR, RR.End(xlDown)).Resize(, 元列数)
VV = RR.Value
C = 指定行 * 指定列
Pmax = UBound(VV) \ C
If (UBound(VV) Mod C) <> 0 Then
Pmax = Pmax + 1
End If
ReDim V2(1 To Pmax * 指定行, 1 To 元列数 * 指定列)
i = 1: j = 1: P = 1: ii = 1
Do While P <= Pmax And ii <= UBound(VV)
Do While j <= 元列数 * 指定列 And ii <= UBound(VV)
Do While i <= 指定行 And ii <= UBound(VV)
For k = 0 To 元列数 - 1
V2((P - 1) * 指定行 + i, j + k) = VV(ii, 1 + k)
Next
i = i + 1
ii = ii + 1
Loop
i = 1
j = j + 元列数
Loop
j = 1
P = P + 1
Loop
Set rngDest = Worksheets.Add.Range("A1")
rngDest.Resize(UBound(V2), UBound(V2, 2)).Value = V2
End Sub
Option Explicit
Option Compare Text
Sub LoadPictures()
Dim Fld As String
Dim Fname As String
Dim Fnames As Variant
Dim Fc As Integer
Dim Pic As Shape
Dim i As Integer
'取り込み後の画像サイズ
Const PicWcm As Single = 5.5
Const PicHcm As Single = 8 '必ず横より縦の方を長く指定すること（横長画像は縦横入替えて設定される）
Dim PicW As Single, PicH As Single
'用紙の左と上余白＆貼り付け有効幅と高さcm
Const LMcm As Single = 1
Const TMcm As Single = 1
Const PWcm As Single = 19.5
Const PHcm As Single = 28.2
Dim LM As Single, TM As Single, PW As Single, PH As Single
Const gap As Single = 1 '画像間スキマpoint
Dim L As Single '画像の貼付け位置左
Dim T As Single '画像の貼付け位置上
Dim T1 As Single '次行の画像貼付け位置上
Dim R As Range
Fld = フォルダ選択("画像フォルダ選択(*.jpg,*.jpeg)")
If Fld = "" Then Exit Sub
Fld = Fld & "\"
'ファイル名取り込み＆並べ替え
Fc = 0
Fname = Dir(Fld & "*.jp*")
Do Until Fname = ""
If LCase(Fname) Like "*.jpg" Or LCase(Fname) Like "*.jpeg" Then
Fc = Fc + 1
If Fc = 1 Then
ReDim Fnames(1 To 1)
Else
ReDim Preserve Fnames(1 To Fc)
End If
Fnames(Fc) = Fname
End If
Fname = Dir()
Loop
If Fc = 0 Then
MsgBox "対象ファイルがありません。", vbExclamation
Exit Sub
End If
Fnames = Csort(Fnames)
PicW = Application.CentimetersToPoints(PicWcm)
PicH = Application.CentimetersToPoints(PicHcm)
LM = Application.CentimetersToPoints(LMcm)
TM = Application.CentimetersToPoints(TMcm)
PW = Application.CentimetersToPoints(PWcm)
PH = Application.CentimetersToPoints(PHcm)
Application.ScreenUpdating = False
With ActiveDocument.PageSetup
.LeftMargin = LM
.TopMargin = TM
.RightMargin = .PageWidth - LM - PW
.BottomMargin = .PageHeight - TM - PH
.HeaderDistance = 0
.FooterDistance = 0
End With
L = 0: T = 0: T1 = 0
For i = 1 To Fc
Fname = Fnames(i)
Application.StatusBar = i & "／" & Fc
Set R = ActiveDocument.Range
R.SetRange R.End - 1, R.End
Set Pic = ActiveDocument.Shapes.AddPicture(Fld & Fname, _
LinkToFile:=False, SaveWithDocument:=True, Anchor:=R)
With Pic
'縮小（サイズオーバーしないように長い方を縮小する）
.LockAspectRatio = msoTrue
If .Height >= .Width Then
'縦長画像の場合
If .Width / .Height > PicW / PicH Then
.Width = PicW
Else
.Height = PicH
End If
Else
'横長画像の場合
If .Width / .Height > PicH / PicW Then
.Width = PicH
Else
.Height = PicW
End If
End If
'位置調整
If L + .Width > PW Then
'次行
L = 0
T = T1
End If
If T + .Height > PH Then
'次ページ
'下記Cut&Pasteで.Width等が得られなくなるのでその前に実行
L = 0
L = L + .Width + gap
T = 0
T1 = T + .Height + gap
'次ページの先頭へ移動、但し本当の移動は無理のようなのでCut&Paste
.Select
Selection.Cut
次ページ追加
Selection.Paste
With Selection
.ShapeRange(1).Left = 0
.ShapeRange(1).Top = 0
.Collapse
End With
Else
'同ページ
.Left = L
.Top = T
L = L + .Width + gap
If T + .Height + gap > T1 Then T1 = T + .Height + gap
End If
End With
Next i
Application.ScreenUpdating = True
End Sub
Sub 次ページ追加()
Dim R As Range
Set R = ActiveDocument.Range
R.SetRange R.End, R.End
With R
.InsertBreak Type:=wdPageBreak
.Select
End With
End Sub
Sub LoadPictures3()
'1枚目の貼り付け位置、2枚目以降の相対位置、改ページの行数は適宜修正のこと
Dim Fnames As Variant
Dim Fn As Variant
Dim i As Integer
Dim Pic As Picture
Dim R As Range
Dim Pc As Integer
Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True)
If TypeName(Fnames) = "Boolean" Then Exit Sub
Application.ScreenUpdating = False
'一枚目の貼付け位置
Set R = Range("A1")
Pc = 0
For i = 1 To UBound(Fnames)
Set Pic = ActiveSheet.Pictures.Insert(Fnames(i))
Select Case (i - 1) Mod 3 + 1
Case 1
Pc = Pc + 1
If Pc >= 2 Then
ActiveSheet.HPageBreaks.Add R
End If
With R
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 200
End With
Case 2
With R.Offset(15, 5) '一枚目に対する二枚目の相対位置
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 200
Pic.Height = 100
End With
Case 3
With R.Offset(25, 2) '一枚目に対する三枚目の相対位置
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 150
Pic.Height = 300
End With
'次ページの相対位置
Set R = R.Offset(50)
End Select
Next
Application.ScreenUpdating = True
End Sub
Sub LoadPictures2()
Dim Fld As String
Dim Fname As String
Dim Pic As Picture
Const PicWcm As Single = 8 '幅
Const PicHcm As Single = 9 '高さ（必ず幅より高さの方を長く指定すること）
Dim PicW As Long, PicH As Long
Const LMcm As Single = 1 '左右余白
Const TMcm As Single = 1 '上下余白
Dim LM As Long, TM As Long, PW As Long, PH As Long
Const Gap As Long = 2 '画像間隙間（ポイント）
Dim L As Long
Dim T As Long
Dim T1 As Long '画像次行トップ位置
Dim C As Integer '画像行数カウント
Dim rngTemp As Range
Fld = フォルダ選択(Title:="画像フォルダ選択(*.jpg,*.jpeg)")
If Fld = "" Then Exit Sub
Fld = Fld & "\"
PicW = CLng(Application.CentimetersToPoints(PicWcm))
PicH = CLng(Application.CentimetersToPoints(PicHcm))
LM = CLng(Application.CentimetersToPoints(LMcm))
TM = CLng(Application.CentimetersToPoints(TMcm))
PW = CLng(Application.CentimetersToPoints(21 - LMcm * 2)) 'A4たて基準
PH = CLng(Application.CentimetersToPoints(30 - TMcm * 2)) ' 〃
Application.ScreenUpdating = False
Workbooks.Add
With ActiveCell.Worksheet.PageSetup
.LeftMargin = LM
.RightMargin = LM
.TopMargin = TM
.BottomMargin = TM
.HeaderMargin = TM
.FooterMargin = TM
End With
C = 1
L = 0: T = 0
T1 = 0
Fname = Dir(Fld & "*.jp*")
Do Until Fname = ""
If LCase(Fname) Like "*.jpg" Or LCase(Fname) Like "*.jpeg" Then
Set Pic = ActiveSheet.Pictures.Insert(Fld & Fname)
With Pic.ShapeRange(1)
'縮小
.LockAspectRatio = msoTrue
If .Height >= .Width Then
If .Width / .Height > PicW / PicH Then
.Width = PicW
Else
.Height = PicH
End If
Else
If .Width / .Height > PicH / PicW Then
.Width = PicH
Else
.Height = PicW
End If
End If
'これから貼り付ける画像の幅がはみ出るようなら次行に移る
If L + Gap + .Width > LM + PW Then
L = 0
T = T1
C = C + 1
End If
'画像行数３行毎に改ページを挿入する
If C > 3 Then
ActiveSheet.HPageBreaks.Add before:=rngTemp
L = 0
T = rngTemp.Top + Gap
T1 = T
C = 1
End If
.Left = L
.Top = T
L = L + Gap + .Width
If T + Gap + .Height > T1 Then
T1 = T + Gap + .Height
Set rngTemp = .BottomRightCell.Offset(1)
End If
End With
End If
Fname = Dir()
Loop
Application.ScreenUpdating = True
End Sub
'選択したフォルダのフルパスを返す、キャンセル又はエラーなら""を返す
Public Function フォルダ選択(Optional Title As String = "フォルダを選択して下さい。", _
Optional RootFolder As Variant) As String
'参照設定するなら、Microsoft Shell Controls And Automationに
Dim Shl As Object 'Shell32.Shell
Dim Fld As Object 'Folder
Dim strFld As String
Set Shl = CreateObject("Shell.Application")
'1:コントロールパネルなどの余分なもの非表示 512:新規フォルダ作成ボタン非表示
If IsMissing(RootFolder) Then
Set Fld = Shl.BrowseForFolder(0, Title, 1 + 512)
Else
Set Fld = Shl.BrowseForFolder(0, Title, 1 + 512, RootFolder)
End If
strFld = ""
If Not Fld Is Nothing Then
On Error Resume Next
strFld = Fld.Self.Path
If strFld = "" Then
strFld = Fld.Items.Item.Path
End If
On Error GoTo 0
End If
If InStr(strFld, "\") = 0 Then strFld = ""
フォルダ選択 = strFld
Set Fld = Nothing
Set Shl = Nothing
End Function
Sub LoadPictures()
Dim myPic As Picture
Dim myPath As String
Dim Fname As String
Dim myCell As Range
myPath = ThisWorkbook.Path & "\"
Set myCell = Range("A1")
Fname = Dir(myPath & "*.jpeg")
Do Until Fname = ""
Set myPic = myCell.Worksheet.Pictures.Insert(myPath & Fname)
With myPic
.Left = myCell.Left
.Top = myCell.Top
End With
Set myCell = myCell.Worksheet.Cells(myPic.BottomRightCell.Row + 1, 1)
Fname = Dir()
Loop
End Sub
Sub 画像貼付け()
Dim Fname As Variant
Dim L As Single
Dim T As Single
Dim W As Single
Dim H As Single
W = Application.CentimetersToPoints(10)
H = Application.CentimetersToPoints(10)
Fname = Application.GetOpenFilename("ピクチャー(*.jpg),*.jpg")
If Fname = False Then Exit Sub
With ActiveCell
.Worksheet.Shapes.AddPicture Fname, msoFalse, msoTrue, .Left, .Top, W, H
End With
End Sub
===== フォームモジュール(UserForm1) =====
Option Explicit
'クラスのインスタンス保持用
Private colText As Collection
Private Sub UserForm_Initialize()
Dim myCopy As cCopyPaste
Dim myText As MSForms.Control
Set colText = New Collection
'TextBoxとComboBoxに対して設定する
For Each myText In Me.Controls
If TypeOf myText Is MSForms.TextBox Then
Set myCopy = New cCopyPaste
Set myCopy.Text = myText
colText.Add myCopy
ElseIf TypeOf myText Is MSForms.ComboBox Then
Set myCopy = New cCopyPaste
Set myCopy.Comb = myText
colText.Add myCopy
End If
Next
End Sub
Private Sub UserForm_Terminate()
Dim i As Integer
For i = 1 To colText.Count
colText.Remove 1
Next
Set colText = Nothing
End Sub
===== 標準モジュール(Module1) =====
Option Explicit
'「UserForm1」は適宜変更のこと
Sub ShowForm()
UserForm1.Show
End Sub
'Functionにしたのはマクロリストに表示しないため。以下同様。
Public Function 切り取り()
UserForm1.ActiveControl.Cut
End Function
Public Function コピー()
UserForm1.ActiveControl.Copy
End Function
Public Function 貼り付け()
UserForm1.ActiveControl.Paste
End Function
===== クラスモジュール(cCopyPaste) =====
Option Explicit
'コピー＆ペースト用プロシージャのプロジェクト名とモジュール名。ここは適宜変更のこと。
Private Const Project As String = "myProject.Module1"
Public WithEvents Text As MSForms.TextBox
Public WithEvents Comb As MSForms.ComboBox
'ComboBoxがリスト表示している時はショートカットメニューを表示しないようにするため
Private flgDrop As Boolean
Private Sub Class_Terminate()
Set Text = Nothing
Set Comb = Nothing
End Sub
Private Sub Comb_DropButtonClick()
'リスト表示中はTrueとなる
flgDrop = Not flgDrop
End Sub
Private Sub Comb_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If flgDrop Then Exit Sub 'リスト表示中は無効にする
MouseUp Button, Comb
End Sub
Private Sub Text_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
MouseUp Button, Text
End Sub
Private Sub MouseUp(ByVal Button As Integer, Ctrl As MSForms.Control)
If Button <> 2 Then Exit Sub
Dim Cb As CommandBar
Dim Btn As CommandBarButton
Set Cb = Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
Set Btn = Cb.Controls.Add(Type:=msoControlButton)
With Btn
.Caption = "切り取り"
.OnAction = Project & ".切り取り"
'テキスト未選択時は無効にする
If Ctrl.SelText = "" Then
.Enabled = False
End If
End With
Set Btn = Cb.Controls.Add(Type:=msoControlButton)
With Btn
.Caption = "コピー"
.OnAction = Project & ".コピー"
'テキスト未選択時は無効にする
If Ctrl.SelText = "" Then
.Enabled = False
End If
End With
Set Btn = Cb.Controls.Add(Type:=msoControlButton)
With Btn
.Caption = "貼り付け"
.OnAction = Project & ".貼り付け"
'クリップボードに文字列が無い時は無効にする
If Not Ctrl.CanPaste Then
.Enabled = False
End If
End With
Cb.ShowPopup
Cb.Delete
End Sub
Sub グループ毎に新規シートへ()
'グループ基準列で並べ替え済であること
Dim RR As Range
Dim myTitle As Range
Dim myCol As Range
Dim S As Long, E As Long
Dim i As Long
Dim maxRow As Long
Dim V As Variant
Dim rngDest As Range
'元データ範囲、タイトル行、グループ基準列取得
Set RR = Range("A1").CurrentRegion
Set myTitle = RR.Rows(1)
Set RR = RR.Offset(1).Resize(RR.Rows.Count - 1)
Set myCol = RR.Columns(RR.Columns.Count)
maxRow = myCol.Rows.Count
'グループの最初と最後の行番号を見つけながら処理
Do
S = E + 1
V = myCol.Cells(S).Value
i = S
Do
i = i + 1
Loop Until myCol.Cells(i).Value <> V Or i > maxRow
E = i - 1
'新規シートを追加して、タイトルと中身を書き出し、シート名をグループの値とする
Set rngDest = Worksheets.Add(after:=Sheets(Sheets.Count)).Range("A1")
myTitle.Copy rngDest
RR.Rows(S & ":" & E).Copy rngDest.Offset(1)
rngDest.Worksheet.Name = V
Loop Until i > maxRow
Set RR = Nothing
Set myTitle = Nothing
Set myCol = Nothing
Set rngDest = Nothing
End Sub
Sub Ksen()
Dim Coll As Collection
Dim RR As Range
Dim Are As Range
Dim R As Range
Dim i As Long
Const N As Integer = 5 'オートフィルタ範囲中の値比較対象列
Set Coll = New Collection
Set RR = ActiveCell.Worksheet.AutoFilter.Range
RR.Borders(xlInsideHorizontal).LineStyle = xlNone
Set RR = RR.SpecialCells(xlCellTypeVisible)
For Each Are In RR.Areas
For Each R In Are.Columns(N).Cells
Coll.Add R
Next
Next
For i = 1 To Coll.Count - 1
If Coll(i).Value <> Coll(i + 1).Value Then
With Intersect(Coll(i).EntireRow, RR)
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
End If
Next
Set Coll = Nothing
End Sub
Sub CallTest_GetNewFileName()
Dim F As String
F = GetNewFileName(ThisWorkbook.Path, Array("*.txt", "*.csv", "*.doc"))
MsgBox F
End Sub
'指定フォルダ中の指定ファイル(ワイルドカード名、配列可)から最新のファイル名を返す、無ければ""
Private Function GetNewFileName(TargetPath As String, Fnames As Variant) As String
Dim Fso As Object 'FileSystemObject
Dim Fl As Object 'Folder
Dim F As Object 'File
Dim myFile As Object 'File
Dim myDate As Date '更新日時の最新値
Dim Flg As Boolean 'Fnamesに一致したかどうかのフラグ
Dim Fn As Variant
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fl = Fso.GetFolder(TargetPath)
For Each F In Fl.Files
'指定ファイルか確認
Flg = False
'配列で指定されている時
If IsArray(Fnames) Then
For Each Fn In Fnames
If LCase(F.Name) Like LCase(Fn) Then
Flg = True
Exit For
End If
Next
Else
'単一指定の時
If LCase(F.Name) Like LCase(Fnames) Then
Flg = True
End If
End If
'更新日が最新のファイルを抽出（作成日なら、.DateCreated）
If Flg Then
If myFile Is Nothing Then
Set myFile = F
myDate = myFile.DateLastModified
ElseIf F.DateLastModified > myDate Then
Set myFile = F
myDate = myFile.DateLastModified
End If
End If
Next
If Not myFile Is Nothing Then
GetNewFileName = myFile.Name
Else
GetNewFileName = ""
End If
Set myFile = Nothing
Set F = Nothing
Set Fl = Nothing
Set Fso = Nothing
End Function
Sub LoopFiles()
Dim BF As Object
Dim Fp As String
Dim Fso As Object 'FileSystemObject
Dim Fld As Object 'Folder
Dim Fl As Object 'File
Dim Wb As Workbook
Set BF = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください。", 513)
If BF Is Nothing Then Exit Sub
On Error Resume Next
Fp = BF.Self.Path
If Fp = "" Then
Fp = BF.Items.Item.Path
End If
On Error GoTo 0
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fld = Fso.GetFolder(Fp)
For Each Fl In Fld.Files
If LCase(Fl.Name) = LCase(ThisWorkbook.Name) Then
ElseIf LCase(Fl.Name) Like "*.xls" Then
'処理
Debug.Print Fl.Path
' Set Wb = Workbooks.Open(Fl.Path)
' 'オープンしたブックに対する処理
' Wb.Close
End If
Next
Set BF = Nothing
Set Fso = Nothing
Set Fld = Nothing
Set Fl = Nothing
Set Wb = Nothing
End Sub
仕様
下記「あ」「い」「選」は各々セルで、このシートの現在の使用範囲
「選」は、Ctrlを押しながら選択したセル
実行すると、二列め以降の「い」と「選」の部分が選択される
あああああああ
あい選いいいい
あああああああ
あ選いいいいい
あいいい選いい
あああああああ
Sub mySelect()
Dim Ur As Range
Dim RR As Range
Set RR = Selection
Set Ur = RR.Worksheet.UsedRange
Set Ur = Intersect(Ur, Ur.Offset(, 1))
Set RR = RR.EntireRow
Set RR = Intersect(RR, Ur)
RR.Select
End Sub
Sub セル結合()
Dim R As Range
Set R = Range("A1")
Do Until R.Value = ""
Application.DisplayAlerts = False
R.MergeArea.Resize(, 2).Columns(2).Merge
Application.DisplayAlerts = True
Set R = R.Offset(1)
Loop
End Sub
Sub 同値セル結合()
Dim S As Range
Dim E As Range
Set S = Range("A1")
Set E = S
Do Until S.Value = ""
Set E = E.Offset(1)
If E.Value = E.Offset(-1).Value Then
Else
Application.DisplayAlerts = False
Range(S, E.Offset(-1)).Merge
Application.DisplayAlerts = True
Set S = E
End If
Loop
End Sub
Sub セル結合解除()
Dim Dic As Object
Dim RR As Range
Dim R As Range
Dim M As Range
Dim V As Variant
Set RR = Selection
Set RR = Intersect(RR, RR.Worksheet.UsedRange)
Set Dic = CreateObject("Scripting.Dictionary")
'結合セルを抽出する
For Each R In RR.Cells
Set M = R.MergeArea
If M.Address <> R.Address Then
Set Dic.Item(M.Address) = M
End If
Next
For Each V In Dic.Keys
Set M = Dic.Item(V)
結合解除 M
Next
Set M = Nothing
Set R = Nothing
Set RR = Nothing
Set Dic = Nothing
End Sub
Private Sub 結合解除(M As Range)
With M
'結合解除
.UnMerge
'同値で埋める
.Value = .Cells(1).Value
'文字色（中央のみ黒、あとは白）
.Font.Color = vbWhite
.Cells((.Cells.Count - 1) \ 2 + 1).Font.ColorIndex = xlAutomatic
'セルを白で塗りつぶし
.Interior.Color = vbWhite
.Interior.Pattern = xlSolid
'枠を25%の灰色に
.BorderAround xlContinuous, xlThin, 15
End With
End Sub
===== シートモジュール =====
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim R As Range
Set R = Target
With Range("A2,A3,C2,D4")
If Intersect(.Cells, R) Is Nothing Then Exit Sub
.Select
R.Activate
End With
End Sub
Sub test()
ActiveSheet.UsedRange.Copy
ClipBoardToTextFile ThisWorkbook.Path & "\test.txt"
Application.CutCopyMode = False
End Sub
'Microsoft Forms x.x Object Library と
'Microsoft Scripting Runtime に参照設定要
Private Sub ClipBoardToTextFile(Pathh As String)
'クリップボードの内容をテキストファイルに書き出す
Dim Doj As DataObject
Dim V As String
Dim Fso As FileSystemObject
Dim Ts As TextStream
Set Doj = New DataObject
With Doj
.GetFromClipboard
On Error Resume Next
V = .GetText
On Error GoTo 0
End With
If V <> "" Then
Set Fso = New FileSystemObject
Set Ts = Fso.OpenTextFile(Pathh, 2, True)
Ts.Write V
Ts.Close
End If
Set Doj = Nothing
Set Ts = Nothing
Set Fso = Nothing
End Sub
Option Explicit
Private myRow As Long
Private mySheet As Worksheet '出力先シート
'何階層めまで対象とするか（指定フォルダを１階層めとする。設定は2以上。0なら全階層が対象。）
Const max階層 As Long = 0
Const 更新日指定 As Boolean = True
Const サイズ指定 As Boolean = False
Const 連結文字 As String = " --- "
Const HyperLink指定 As Boolean = True
Const ワイルドカード As String = "*.xls"
Private Sub 実行()
Dim path始点 As String
Dim myMsg As String
path始点 = "D:\My Documents"
'ドライブのルートの時は\をカットする
If path始点 Like "?:\" Then
path始点 = Left$(path始点, 2)
End If
Application.ScreenUpdating = False
Set mySheet = Application.Workbooks.Add.Worksheets(1)
myRow = 1
GetFileLists FolderPath:=path始点, myColumn:=1
Application.ScreenUpdating = True
Set mySheet = Nothing
End Sub
Private Sub GetFileLists(FolderPath As String, myColumn As Long _
, Optional ParentFolder As Range = Nothing)
'フォルダ､直下のファイル､サブフォルダを表示する｡（FolderPathの最後に\は無し）
'1つ設定したら行はカウントアップする。
'親フォルダがある時は、フォルダの左セルから親フォルダの下セルへ、左と下に罫線を引く
'下位フォルダがある場合は、パスにフォルダ名を＋し、列を+1して再帰呼び出しをする。
Dim myDirs As Variant
Dim 表示名 As String
Dim Folders() As String 'ワイルドカードにマッチしたフォルダ名のリスト
Dim cF As Integer 'フォルダ名カウント
Dim strTemp As String
Dim i As Integer
Dim rngFolder As Range '現フォルダ
Dim rngTemp As Range
If myColumn = 1 Then
表示名 = FolderPath
Else
myDirs = Split(FolderPath, "\")
表示名 = myDirs(UBound(myDirs))
End If
Set rngFolder = mySheet.Cells(myRow, myColumn)
With rngFolder
.Value = 表示名
.Interior.Color = vbYellow
If HyperLink指定 Then
mySheet.Hyperlinks.Add Anchor:=.Cells(1), Address:=FolderPath
End If
End With
'親フォルダがある時は
If Not ParentFolder Is Nothing Then
'親フォルダの下から現フォルダの左まで
Set rngTemp = mySheet.Range(ParentFolder.Offset(1, 0) _
, rngFolder.Offset(0, -1))
With rngTemp
'左と
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'下の罫線を引く
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End If
myRow = myRow + 1
'ファイルリスト表示
On Error GoTo Trap
strTemp = Dir(FolderPath & "\" & ワイルドカード, vbNormal)
On Error GoTo 0
Do While strTemp <> ""
If (GetAttr(FolderPath & "\" & strTemp) And vbNormal) = vbNormal Then
表示名 = strTemp
If 更新日指定 Then
表示名 = 表示名 & 連結文字 & FileDateTime(FolderPath & "\" & strTemp)
End If
If サイズ指定 Then
表示名 = 表示名 & 連結文字 & Format(FileLen(FolderPath & "\" & strTemp), "0,0")
End If
With mySheet.Cells(myRow, myColumn + 1)
.Value = 表示名
If HyperLink指定 Then
mySheet.Hyperlinks.Add Anchor:=.Cells(1), _
Address:=FolderPath & "\" & strTemp
End If
End With
myRow = myRow + 1
End If
strTemp = Dir()
Loop
'下位フォルダを取り出す
cF = 0
strTemp = Dir(FolderPath & "\*.*", vbDirectory)
Do While strTemp <> ""
If strTemp = "." Or strTemp = ".." Then
'nop
ElseIf (GetAttr(FolderPath & "\" & strTemp) And vbDirectory) = vbDirectory Then
'フォルダ
cF = cF + 1
If cF = 1 Then
ReDim Folders(1 To cF)
Else
ReDim Preserve Folders(1 To cF)
End If
Folders(cF) = strTemp
End If
strTemp = Dir()
Loop
Set rngTemp = Nothing
'階層指定なし又は列<指定階層なら
If max階層 < 2 Or myColumn + 1 < max階層 Then
'下位フォルダがある場合は、パスにフォルダ名を＋し、列を+1して再帰呼び出しをする。
For i = 1 To cF
GetFileLists FolderPath & "\" & Folders(i), myColumn + 1, rngFolder
Next
Else
'指定の最終階層なら
For i = 1 To cF
Set rngFolder = mySheet.Cells(myRow, myColumn + 1)
With rngFolder
.Value = Folders(i)
.Interior.Color = RGB(255, 127, 0) 'オレンジ色
If HyperLink指定 Then
mySheet.Hyperlinks.Add Anchor:=.Cells(1), _
Address:=FolderPath & "\" & Folders(i)
End If
End With
myRow = myRow + 1
Next
End If
Erase Folders
Exit Sub
Trap:
MsgBox "ワイルドカードの指定が正しくありません。", vbCritical
On Error GoTo 0
End
End Sub
Sub 可視セルへ貼り付け()
'Microsoft Forms 2.0 Object Library に参照設定要
Dim Dobj As DataObject
Dim V As Variant 'クリップボードのデータ全体
Dim A As Variant 'その内の一行
Dim rngDest As Range
Dim R As Range
Dim i As Integer
With ActiveCell.Worksheet.AutoFilter.Range
Set rngDest = .Columns(.Columns.Count + 1) 'とりあえず、貼り付け先はオートフィルタ範囲の右列
Set rngDest = Intersect(rngDest, rngDest.Offset(1))
Set rngDest = rngDest.SpecialCells(xlCellTypeVisible) '最後に可視セルを取得するのがみそ
End With
Set Dobj = New DataObject
With Dobj
.GetFromClipboard
On Error Resume Next
V = .GetText
On Error GoTo 0
End With
If Not IsEmpty(V) Then 'クリップボードからテキストが取得できた時のみ実行
V = Split(CStr(V), vbCrLf)
i = 0
For Each R In rngDest.Cells
A = Split(CStr(V(i)), vbTab)
R.Resize(, UBound(A) + 1).Value = A
i = i + 1
If i > UBound(V) Then Exit For
Next
End If
Set Dobj = Nothing
Set rngDest = Nothing
Set R = Nothing
End Sub
Sub 空白凡例削除()
'棒グラフ用
Dim V As Variant
Dim i As Integer
With ActiveSheet.ChartObjects(1).Chart
On Error Resume Next
.Legend.Delete
.HasLegend = True
On Error GoTo 0
For i = .SeriesCollection.Count To 1 Step -1
V = .SeriesCollection(i).Values
If 空白(V) Then
.Legend.LegendEntries(i).Delete
End If
Next
End With
End Sub
Private Function 空白(V As Variant) As Boolean
Dim i As Integer
Dim Flg As Boolean
Flg = True
For i = LBound(V) To UBound(V)
If V(i) <> "" Then
Flg = False
Exit For
End If
Next
空白 = Flg
End Function
Sub 空白凡例削除2()
'散布図用
Dim V As Variant
Dim i As Integer
With ActiveSheet.ChartObjects(1).Chart
On Error Resume Next
.Legend.Delete
.HasLegend = True
On Error GoTo 0
For i = .SeriesCollection.Count To 1 Step -1
On Error Resume Next
V = .SeriesCollection(i).Values
If Err.Number <> 0 Then
.Legend.LegendEntries(i).Delete
End If
On Error GoTo 0
Next
End With
End Sub
===== ThisWorkbookモジュール =====
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not CloseFlag Then
Cancel = True
Exit Sub
End If
End Sub
===== 標準モジュール =====
Public CloseFlag As Boolean
Sub myClose()
CloseFlag = True
ThisWorkbook.Close
End Sub
===== ThisWorkbook モジュール =====
Option Explicit
Private myCells As Variant
Private CellsCount As Integer
Private Sub Workbook_Open()
Workbook_SheetActivate ActiveSheet
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
'シート毎の設定
Select Case Sh.Name
Case "Sheet1", "Sheet2"
セット
myCells = Array("A1", "C1", "E1", "F1")
Case "Sheet3"
セット
myCells = Array("B2", "D2", "G2", "H2")
Case Else
'対象外シート
リセット
Exit Sub
End Select
Sh.Range("A1").Select
CellsCount = UBound(myCells)
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
リセット
End Sub
Private Sub セット()
Application.OnKey "{ENTER}", "ThisWorkbook.Enterで移動"
Application.OnKey "~", "ThisWorkbook.Enterで移動"
End Sub
Private Sub リセット()
Application.OnKey "{ENTER}"
Application.OnKey "~"
End Sub
Private Sub Enterで移動()
Dim i As Integer
Dim myAddress As String
Dim Flg As Boolean
With ActiveCell
myAddress = .Address(0, 0, xlA1, 0)
For i = 0 To CellsCount
If myCells(i) = myAddress Then
Range(myCells((i + 1) Mod (CellsCount + 1))).Activate
Flg = True
Exit For
End If
Next
End With
'入力対象外の範囲の時
If Not Flg Then
If Application.MoveAfterReturn Then
Select Case Application.MoveAfterReturnDirection
Case xlDown
ActiveCell.Offset(1).Activate
Case xlToRight
ActiveCell.Offset(, 1).Activate
Case xlUp
ActiveCell.Offset(-1).Activate
Case xlToLeft
ActiveCell.Offset(, -1).Activate
End Select
End If
End If
End Sub
Sub セット()
Application.OnKey "{ENTER}", "Enterで移動"
Application.OnKey "~", "Enterで移動"
End Sub
Sub リセット()
Application.OnKey "{ENTER}"
Application.OnKey "~"
End Sub
Sub Enterで移動()
Dim myCells As Variant
Dim C As Integer
Dim i As Integer
Dim myAddress As String
Dim Flg As Boolean
myCells = Array("A1", "C1", "D1", "G1", "A2", "A3", "C2")
C = UBound(myCells)
With ActiveCell
myAddress = .Address(0, 0, xlA1, 0)
For i = 0 To C
If myCells(i) = myAddress Then
Range(myCells((i + 1) Mod (C + 1))).Activate
Flg = True
Exit For
End If
Next
End With
'入力対象外の範囲の時
If Not Flg Then
If Application.MoveAfterReturn Then
On Error Resume Next
Select Case Application.MoveAfterReturnDirection
Case xlDown
ActiveCell.Offset(1).Activate
Case xlToRight
ActiveCell.Offset(, 1).Activate
Case xlUp
ActiveCell.Offset(-1).Activate
Case xlToLeft
ActiveCell.Offset(, -1).Activate
End Select
On Error GoTo 0
End If
End If
End Sub
Sub ReadLongCSV()
'256を超える項目数のCSVファイルを複数のシート(既存)に分割して読み込む
Dim myPath As String
Dim N As Integer
Dim Ld As String 'LineData
Dim Lc As Long 'LineCounter
Dim V As Variant '分割データ
Dim A As Variant '一シート分のデータ
Dim i As Integer, j As Integer
Dim Sc As Integer 'SheetCounter
myPath = ThisWorkbook.Path & "\test.csv"
N = FreeFile
Open myPath For Input As #N
Do Until EOF(N)
Line Input #N, Ld
Lc = Lc + 1
V = Split(Ld, ",")
ReDim A(0 To 255)
i = 0: j = 0: Sc = 0
Do Until i > UBound(V)
A(j) = V(i)
If j = 255 Or i = UBound(V) Then
Sc = Sc + 1
Worksheets(Sc).Cells(Lc, 1).Resize(, j + 1).Value = A
ReDim A(0 To 255)
j = 0
Else
j = j + 1
End If
i = i + 1
Loop
Loop
Close #N
End Sub
Sub CreateTestData()
Dim myPath As String
Dim N As Integer
Dim i As Integer
Dim j As Integer
myPath = ThisWorkbook.Path & "\test.csv"
N = FreeFile
Open myPath For Output As #N
For i = 1 To 100
Print #N, 1;
For j = 2 To 700
Print #N, ","; j;
Next: Print #N, ""
Next
Close #N
End Sub
Sub コントロールツールのコントロール() 'Shapeからアクセスしているがその必要は無さそう、下記2の方がスマート
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
With Shp
If .Type = msoOLEControlObject Then
With .OLEFormat
If .ProgId = "Forms.ComboBox.1" Then
.Object.Object.AddItem "全て" ' .ObjectでOLEObject、さらに.ObjectでComboBoxへの参照を取得している
End If
End With
End If
End With
Next
Set Shp = Nothing
End Sub
Sub コントロールツールのコントロール2()
Dim Obj As OLEObject
For Each Obj In ActiveSheet.OLEObjects
With Obj
If .ProgId = "Forms.ComboBox.1" Then
.Object.AddItem "全て" '.ObjectでComboBoxへの参照を取得している
End If
End With
Next
Set Obj = Nothing
End Sub
Sub test()
Const N As Long = 10000
Dim A(1 To N) As String
Dim i As Long
Dim T As Single
Dim V As String
For i = 1 To N
A(i) = CStr(i)
Next
T = Timer
V = Join97(A, ",")
Debug.Print Timer - T
Debug.Print V
End Sub
Public Function Join97(List As Variant, Optional Delimiter As String = " ") As String
Dim L As Long, U As Long
Dim Ret As String
Dim i As Long
Dim Ld As Long
Dim Tlen As Long
Dim j As Long
Dim LL As Long
L = LBound(List)
U = UBound(List)
Ld = Len(Delimiter)
'デリミタを含めたトータル長さ
Tlen = Len(List(L))
For i = L + 1 To U
Tlen = Tlen + Ld + Len(List(i))
Next
'予め必要分の長さの文字列を確保
Ret = String$(Tlen, " ")
If Delimiter = " " Or Delimiter = "" Then
'デリミタがスペースか "" なら置換え必要無し
j = 1 '次の文字の置き換えポイント
If List(L) <> "" Then
LL = Len(List(L))
Mid$(Ret, j, LL) = List(L)
j = j + LL
End If
For i = L + 1 To U
j = j + Ld
If List(i) <> "" Then
LL = Len(List(i))
Mid$(Ret, j, LL) = List(i)
j = j + LL
End If
Next
Else
'デリミタも置き換える
j = 1
If List(L) <> "" Then
LL = Len(List(L))
Mid$(Ret, j, LL) = List(L)
j = j + LL
End If
For i = L + 1 To U
Mid$(Ret, j, Ld) = Delimiter
j = j + Ld
If List(i) <> "" Then
LL = Len(List(i))
Mid$(Ret, j, LL) = List(i)
j = j + LL
End If
Next
End If
Join97 = Ret
End Function
Sub SortCSV()
Dim myPath As String
Dim N As Integer
Dim D As String
Const Cn As Integer = 4 '列数
Const Kn As Integer = 2 'キー列番号
Dim V() As Variant
Dim i As Long, j As Long
Dim Ky() As Variant
Dim Ndx As Variant
myPath = ThisWorkbook.Path & "\test.csv"
N = FreeFile()
Open myPath For Input As #N
Do Until EOF(N)
i = i + 1
ReDim Preserve V(1 To Cn, 1 To i)
ReDim Preserve Ky(1 To i)
For j = 1 To Cn
Input #N, V(j, i)
If j = Kn Then
Ky(i) = V(j, i)
End If
Next
Loop
Close #N
Ndx = MsCombSortI(Ky)
N = FreeFile()
Open myPath For Output As #N
For i = 1 To UBound(V, 2)
Print #N, V(1, Ndx(i));
For j = 2 To Cn
Print #N, ","; V(j, Ndx(i));
Next
Print #N, ""
Next
Close #N
MsgBox "完了！"
End Sub
Private Sub CreateTestDataFile()
'範囲を指定した整数を羅列した、４列のテキストファイルを作る。
Dim Fn As String
Dim N As Long
Dim i As Long
Const L2 As Long = 1
Const U2 As Long = 300
Const L3 As Long = 1
Const U3 As Long = 1000
Const L4 As Long = 1
Const U4 As Long = 700
Fn = ThisWorkbook.Path & "\test.csv"
N = FreeFile(0)
Open Fn For Output As #N
Randomize
For i = 1 To 60000
Print #N, i; ","; Int((U2 - L2 + 1) * Rnd() + L2) _
; ","; Int((U3 - L3 + 1) * Rnd() + L3) _
; ","; Int((U4 - L4 + 1) * Rnd() + L4)
Next
Close #N
End Sub
Sub CSV作成()
'二行で一レコードのワークシート上のデータをCSVに書き出す
Dim myPath As String
Dim N As Integer
Dim myRange As Range
Dim myRow As Range
Dim Flg As Boolean
Dim i As Integer
myPath = ActiveWorkbook.Path & "\Test.csv"
N = FreeFile
Set myRange = ActiveSheet.UsedRange
Open myPath For Output As #N
For Each myRow In myRange.Rows
Flg = Not Flg
If Flg Then
Print #N, myRow.Cells(1).Value;
For i = 2 To myRow.Cells.Count * 2
Print #N, ","; myRow.Resize(2).Cells(i).Value;
Next
Print #N, ""
End If
Next
Close #N
End Sub
Sub 別シートに分割()
'同項目毎に別シートに分割する
Dim Dic As Object 'Dictionary
Dim K As Variant
Dim RR As Range
Dim R As Range
Dim T As Range 'タイトル
Set T = Range("A1")
Set RR = T.Offset(1)
Set RR = Range(RR, RR.End(xlDown))
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1 'BinaryCompare=0, TextCompare=1
For Each R In RR
K = CStr(R.Value)
If Dic.Exists(K) Then
Set Dic(K) = Union(Dic(K), R)
Else
Set Dic(K) = Union(T, R)
End If
Next
For Each K In Dic.Keys
With Worksheets.Add
.Name = K
Set R = Dic(K)
Set R = R.EntireRow
Set R = Intersect(R, R.Worksheet.UsedRange)
R.Copy .Range("A1")
End With
Next
Set Dic = Nothing
End Sub
Function Language() As String
Dim myStyle As Style
Set myStyle = ThisWorkbook.Styles("Normal")
Select Case myStyle.NameLocal
Case "Normal"
Language = "English"
Case "標準"
Language = "日本語"
Case Else
Language = "Other"
End Select
Set myStyle = Nothing
End Function
Sub コマンドバートグルボタン()
Dim myButton As Office.CommandBarButton
Set myButton = Application.CommandBars.ActionControl
With myButton
If .State = msoButtonUp Then
'ボタンを押し込んだ時の処理
ActiveSheet.DisplayAutomaticPageBreaks = True
.State = msoButtonDown
Else
'ボタンを戻したときの処理
ActiveSheet.DisplayAutomaticPageBreaks = False
.State = msoButtonUp
End If
End With
Set myButton = Nothing
End Sub
===== ThisWorkbookモジュール =====
Option Explicit
Private flgText As String
Private Sub Workbook_Open()
flgText = ThisWorkbook.Path & "\次回から表示しない.txt"
If 表示しない Then Exit Sub
UserForm1.Show
If UserForm1.戻り値 = vbOK Then
チェックON
End If
Unload UserForm1
End Sub
Private Function 表示しない() As Boolean
If Dir(flgText) <> "" Then
表示しない = True
Else
表示しない = False
End If
End Function
Private Sub チェックON()
Dim N As Integer
N = FreeFile
Open flgText For Output As #N
Close #N
End Sub
===== UserForm1モジュール =====
Option Explicit
Public 戻り値 As Integer
Private Sub cmdOK_Click()
If Me.chk次回から表示しない.Value = True Then
戻り値 = vbOK
Else
戻り値 = vbCancel
End If
Me.Hide
End Sub
Private Sub UserForm_Initialize()
戻り値 = vbCancel
Me.chk次回から表示しない.Value = False
End Sub
Sub WriteTxt()
'シートの選択範囲をタブ区切りテキストとして出力する
'Microsoft Forms x.x Object Libraryに参照設定要
Dim Doj As DataObject
Dim Txt As String
Dim RR As Range
Dim myPath As String
Dim N As Integer
Set RR = Selection
RR.Copy
Set Doj = New DataObject
With Doj
.GetFromClipboard
Txt = .GetText
End With
Set Doj = Nothing
Application.CutCopyMode = False
myPath = ThisWorkbook.Path & "\test.txt"
N = FreeFile()
Open myPath For Output As #N
Print #N, Txt;
Close #N
End Sub
Sub 二段組()
Dim myRange As Range
Dim R As Integer, C As Integer
Dim myRow As Range
Dim myColumn As Range
Set myRange = Range("A1").CurrentRegion
With myRange
'項目数
C = .Columns.Count
'項目名のコピー
.Rows(1).Copy .Cells(1, C + 1)
'正味の行数の半分（元が奇数なら一行少なくコピペする）
R = Int((.Rows.Count - 1) / 2)
'下からR行分
With .Rows(.Rows.Count).Offset(-R + 1).Resize(R)
.Copy myRange.Cells(2, C + 1)
.Clear
'列幅のコピー
For Each myColumn In .Columns
With myColumn
.Offset(, C).ColumnWidth = .ColumnWidth
End With
Next
End With
'罫線で囲む
'正味の行数の半分（元が奇数なら一行多い方）
R = Application.WorksheetFunction _
.RoundUp((.Rows.Count - 1) / 2, 0)
'項目行とR行分を含む回りを罫線で囲む
With .Rows(1).Resize(1 + R)
.BorderAround LineStyle:=xlContinuous
'コピペした隣も
.Offset(, C).BorderAround LineStyle:=xlContinuous
End With
End With
'一行おきに色付け
R = 0
For Each myRow In myRange.CurrentRegion.Rows
R = Not R
If R Then
myRow.Interior.Color = vbYellow
End If
Next
End Sub
Sub 結合セル範囲毎の並べ替え()
Dim R As Range
Dim C As Integer
Set R = Range("B1") '結合していない列を基準にして処理するのがみそ
Do Until R.Offset(, -1).Value = ""
C = R.Offset(, -1).MergeArea.Rows.Count
R.Resize(C).Sort key1:=R, header:=xlNo
Set R = R.Offset(C)
Loop
End Sub
Sub test()
Dim A As Variant
Dim V As Variant
A = 乱配列(5, 10)
For Each V In A
Debug.Print V;
Next
Debug.Print
End Sub
Function 乱配列(L As Integer, U As Integer) As Variant
'LからUの範囲の重複の無い乱配列を返す。添え字は１から。
Dim M As Integer
Dim A As Variant
Dim i As Integer
Dim N As Integer
Dim V As Integer
M = U - L + 1
ReDim A(1 To M)
For i = 1 To M
A(i) = i
Next
Randomize
For i = M To 2 Step -1
N = Int(Rnd() * i + 1)
V = A(N)
A(N) = A(i)
A(i) = V
Next
For i = 1 To M
A(i) = A(i) + L - 1
Next
乱配列 = A
End Function
Sub 乱順文字()
Dim A As Variant
Dim L As Integer, U As Integer
Dim N As Integer
Dim i As Integer, j As Integer
Dim S As String
A = Array("A", "B", "C", "D", "E", "F")
L = LBound(A)
U = UBound(A)
N = U
Randomize
For i = L To U - 1
j = Int(Rnd() * (N - L + 1) + L)
S = S & A(j)
A(j) = A(N)
N = N - 1
Next
S = S & A(L)
Debug.Print S
End Sub
Sub SampleData()
'3文字＋数字２桁＋15文字のランダムな文字列を作成する
Dim A(1 To 10000, 1 To 1) As String
Dim i As Long
Dim S As String
Randomize
For i = 1 To 10000
S = Format(Int(Rnd() * (99 - 1 + 1) + 1), "00")
A(i, 1) = RndStr(3) & S & RndStr(15)
Next
Range("A1").Resize(UBound(A)).Value = A
End Sub
Private Function RndStr(N As Integer) As String
'A-Z,a-zのランダムな文字列N個を返す
Randomize
Dim i As Integer
Dim S As String
Dim SS As String
Dim A As Integer
For i = 1 To N
A = Int(Rnd() * 26)
S = Chr$(Asc("A") + A)
If Rnd() >= 0.5 Then
S = LCase(S)
End If
SS = SS & S
Next
RndStr = SS
End Function
Sub 列比較抽出()
'A列とB列を比較しB列のみの値をC列に抽出する
Dim Dic As Object
Dim AA As Variant
Dim BB As Variant
Dim CC As Variant
Dim rngDest As Range
Dim V As Variant
Dim i As Integer
Set Dic = CreateObject("Scripting.Dictionary")
With ActiveCell.Worksheet
AA = .Range(.Range("A1"), .Range("A65536").End(xlUp)).Value
BB = .Range(.Range("B1"), .Range("B65536").End(xlUp)).Value
Set rngDest = .Range("C1")
End With
For Each V In AA
Dic.Item(V) = Empty
Next
ReDim CC(1 To UBound(BB), 1 To 1)
i = 0
For Each V In BB
If Not Dic.Exists(V) Then
i = i + 1
CC(i, 1) = V
End If
Next
rngDest.Resize(i).Value = CC
Set Dic = Nothing
Set rngDest = Nothing
End Sub
Sub 辞書例()
Const KeyN As Integer = 1 'キー列
Const ItemN As Integer = 2 'アイテム列
Dim Dic As Object
Dim rngDic As Range
Dim myRange As Range
Dim myCell As Range
Dim myValues As Variant
Dim myKey As Variant
Dim i As Long
Set rngDic = Worksheets("Sheet2").UsedRange
Set myRange = Worksheets("Sheet1").Range("A1")
Set myRange = Range(myRange, myRange.End(xlDown))
Set Dic = CreateObject("Scripting.Dictionary")
With rngDic
For i = 1 To .Rows.Count
Dic.Item(.Cells(i, KeyN).Value) _
= .Cells(i, ItemN).Value
Next
End With
ReDim myValues(1 To myRange.Rows.Count, 1 To 1)
i = 0
For Each myCell In myRange.Cells
i = i + 1
myKey = myCell.Value
If Dic.Exists(myKey) Then
myValues(i, 1) = Dic.Item(myKey)
End If
Next
myRange.Offset(, 1).Value = myValues
End Sub
対象のシート名が「Sheet1」だとして、
１．ThisWorkbookモジュールに次のプログラムをコピペします。
２．そして、非表示()をダイレクトに実行してシートを隠します。
３．プロジェクトの保護をします。（もちろんパスワード付きで）
４．ブックを保存します。
これで、ブックを開く時にマクロを有効にしないとシートが表示されません。
そして、マクロが有効になっていれば印刷はキャンセルされます。
（ただし、PrintScreenでは出来てしまうなど、抜け道はありますが。^d^）
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Cancel = True
End Sub
Private Sub Workbook_Open()
With Worksheets("Sheet1")
.Visible = xlSheetVisible
.Select
End With
ThisWorkbook.Saved = True
End Sub
Private Sub 非表示()
Worksheets("Sheet1").Visible = xlSheetVeryHidden
End Sub
[DBNum1]G/標準：123 ===> 百二十三 [DBNum2]G/標準：123 ===> 壱百弐拾参 [DBNum1]ggge"年"m"月"d"日"：2005/7/9 ===> 平成十七年七月九日
Option Explicit
Option Compare Text
Sub CallFind()
Dim myRange As Range
Dim Ans As Variant
Static myKeys As String
Dim rngFind As Range
Set myRange = ActiveSheet.UsedRange
Ans = Application.InputBox("検索キー入力", , myKeys, Type:=2)
If Ans = False Then Exit Sub
myKeys = Replace(CStr(Ans), " ", " ")
Set rngFind = MsFind(myRange, myKeys, ActiveCell)
If rngFind Is Nothing Then
MsgBox "Not Found", vbExclamation
Else
rngFind.Select
End If
End Sub
Private Function MsFind(Target As Range, Keys As String, Optional rngAfter As Range) As Range
'Targetの行単位でKeysを検索し該当行への参照を返す。
'Keysは、スペース区切りでアンド指定可
Dim myRow As Range
Dim myCell As Range
Dim i As Integer
Dim Flg As Boolean
Dim myKeys As Variant
Dim rngFind As Range
Dim FirstAddress As String
If Target Is Nothing Then Exit Function
If Trim(Keys) = "" Then Exit Function
If IsMissing(rngAfter) Then
Set rngAfter = Target.Cells(Target.Cells.Count)
End If
If rngAfter Is Nothing Then
Set rngAfter = Target.Cells(Target.Cells.Count)
End If
Set MsFind = Nothing
myKeys = Split(Trim(Keys), " ")
Set rngFind = Target.Find(what:=myKeys(LBound(myKeys)), after:=rngAfter, _
LookIn:=xlValues, lookat:=xlPart, MatchCase:=False, MatchByte:=False)
If rngFind Is Nothing Then Exit Function
FirstAddress = rngFind.Address
Do
Set myRow = Intersect(rngFind.EntireRow, Target)
For i = LBound(myKeys) To UBound(myKeys)
Flg = False
For Each myCell In myRow.Cells
If myCell.Value Like "*" & myKeys(i) & "*" Then
Flg = True
Exit For
End If
Next
If Flg = False Then
Exit For
End If
Next
If Flg = True Then
Set MsFind = rngFind
Exit Do
End If
Set rngFind = Target.FindNext(rngFind)
Loop Until rngFind.Address = FirstAddress
End Function
===== ThisWorkbookモジュール =====
Option Explicit
Private WithEvents myApp As Application
Private myCount As Integer
Private Flg As Boolean
Private Sub Workbook_Open()
Set myApp = Application
myCount = Application.Windows.Count
Flg = False
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myApp = Nothing
End Sub
Private Sub myApp_WindowActivate(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)
If Flg Then
If Application.Windows.Count < myCount Then
MsgBox "ウインドウが閉じられました。"
End If
End If
Flg = False
myCount = Application.Windows.Count
End Sub
Private Sub myApp_WindowDeactivate(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)
If InStr(Wn.Caption, ":") >= 1 Then
Flg = True
End If
End Sub
===== シートモジュール =====
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim V As Variant
With Target
If .Count >= 2 Then Exit Sub
V = .Value
Application.EnableEvents = False
Application.Undo
If IsEmpty(V) Then 'Delキーを有効にするため
.ClearContents
Else
If VarType(V) = vbString Or VarType(.Value) = vbString Then
.Value = .Value & V
Else
.Value = .Value + V
End If
End If
Application.EnableEvents = True
End With
End Sub
Sub 一行おきの色付け()
Dim myRange As Range
Dim myRow As Range
Dim Sw As Boolean
Set myRange = ActiveSheet.AutoFilter.Range
For Each myRow In myRange.Rows
With myRow
If Not .Hidden Then
If Sw Then
.Interior.Color = vbYellow
Else
.Interior.ColorIndex = xlColorIndexNone
End If
Sw = Not Sw
End If
End With
Next
End Sub
Option Explicit
Private rngSource As Range
Public Sub AddMenu()
Dim myMenuCopy As CommandBarButton
Dim myMenuPast As CommandBarButton
With Application.CommandBars("Cell")
Set myMenuPast = .Controls.Add(before:=1, temporary:=True)
Set myMenuCopy = .Controls.Add(before:=1, temporary:=True)
.Controls(3).BeginGroup = True
End With
With myMenuCopy
.Caption = "UserCopy"
.OnAction = "UserCopy"
End With
With myMenuPast
.Caption = "UserPast"
.OnAction = "UserPast"
End With
End Sub
Public Sub DelMenu()
On Error Resume Next
With Application.CommandBars("Cell")
.Controls("UserCopy").Delete
.Controls("UserPast").Delete
End With
On Error GoTo 0
If Not rngSource Is Nothing Then
rngSource.Interior.ColorIndex = xlNone
End If
End Sub
Private Sub UserCopy()
If Not rngSource Is Nothing Then
rngSource.Interior.ColorIndex = xlNone
End If
Set rngSource = Selection
'コピー元がユーザーに分かるように色を塗っておく
rngSource.Interior.Color = vbCyan
End Sub
Private Sub UserPast()
If rngSource Is Nothing Then Exit Sub
rngSource.Copy
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
===== ThisWorkbook =====
Option Explicit
Private Const ToolName1 As String = "フォームBox"
Private Const ToolName2 As String = "ツールBox"
Private Sub Workbook_BeforeClose(Cancel As Boolean)
DelButton
End Sub
Private Sub Workbook_Open()
AddButton
End Sub
Private Sub AddButton()
Dim myButton As CommandBarButton
With Application.CommandBars("Worksheet Menu Bar")
Set myButton = .Controls.Add _
(Type:=msoControlButton, temporary:=True)
With myButton
.Style = msoButtonCaption
.Caption = ToolName1
.OnAction = "ToolButton.ThisWorkbook.FormBox"
End With
Set myButton = .Controls.Add _
(Type:=msoControlButton, temporary:=True)
With myButton
.Style = msoButtonCaption
.Caption = ToolName2
.OnAction = "ToolButton.ThisWorkbook.ToolBox"
End With
End With
End Sub
Private Sub DelButton()
On Error Resume Next
With Application.CommandBars("Worksheet Menu Bar")
.Controls(ToolName1).Delete
.Controls(ToolName2).Delete
End With
On Error GoTo 0
End Sub
Private Sub FormBox()
With Application.CommandBars("Forms")
.Visible = Not .Visible
End With
End Sub
Private Sub ToolBox()
With Application.CommandBars("Control Toolbox")
.Visible = Not .Visible
End With
End Sub
Sub ReadCsv()
Dim Fld As String
Dim Fn As String
Dim N As Integer
Dim Book As Workbook
Dim Sht As Worksheet
Dim VV As Variant '一ファイルすべてのデータ
Dim V As Variant '一行分のデータ
Dim i As Long
Dim CC As Integer '列数
Fld = フォルダ選択()
If Fld = "" Then Exit Sub
Fn = Dir(Fld & "\*.csv")
If Fn = "" Then Exit Sub
Set Book = Workbooks.Add
Do Until Fn = ""
With Book
Set Sht = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
End With
N = FreeFile
Open Fld & "\" & Fn For Input As #N
VV = InputB(LOF(N), N)
VV = StrConv(VV, vbUnicode)
VV = Split(VV, vbCrLf)
Close #N
V = Split(VV(0), ",")
CC = UBound(V) + 1
Sht.Range("A:A").Resize(, CC).NumberFormat = "@"
For i = 0 To UBound(VV)
V = Split(VV(i), ",")
Sht.Cells(i + 1, 1).Resize(, CC).Value = V
Next
Sht.Name = Left$(Fn, Len(Fn) - 4)
Fn = Dir()
Loop
Application.DisplayAlerts = False
For i = 1 To Application.SheetsInNewWorkbook
Book.Sheets(1).Delete
Next
Application.DisplayAlerts = True
MsgBox "完了！"
End Sub
Sub ChainCsv()
Dim Fls As Variant
Dim F As Variant
Dim Fso As Object 'FileSystemObject
Dim Ts As Object 'TextStream
Dim V As String
Dim VV As String
Dim OutPath As Variant
Fls = Application.GetOpenFilename("CVSファイル(*.csv),*.csv,全てのファイル(*.*),*.*", _
Title:="まとめるファイルを選択してください。", MultiSelect:=True)
If TypeName(Fls) = "Boolean" Then Exit Sub
OutPath = ThisWorkbook.Path & "\Out.Txt"
OutPath = Application.GetSaveAsFilename(OutPath, _
Title:="書き出し先ファイル名を入力してください。")
If VarType(OutPath) = vbBoolean Then Exit Sub
Set Fso = CreateObject("Scripting.FileSystemObject")
VV = ""
For Each F In Fls
Set Ts = Fso.OpenTextFile(F, 1) 'ForReading
With Ts
V = .ReadAll
'最後が改行でない時は強制挿入
If VV <> "" And Right$(VV, 2) <> vbCrLf Then
VV = VV & vbCrLf
End If
VV = VV & Dir(F) & vbCrLf & V
.Close
End With
Next
Set Ts = Fso.OpenTextFile(OutPath, 2, True) 'ForWriting
With Ts
.Write VV
.Close
End With
Set Ts = Nothing
Set Fso = Nothing
End Sub
点数 名前 番号
90 田中 2
80 田中 3
85 田中 1
95 山田 1
小林 1
70 佐藤 1
70 佐藤 2
85 鈴木 1
80 吉田 2
90 吉田 3
70 吉田 4
85 吉田 3
↓
1 2 3 4
吉田 85
80 90 70
佐藤 70 70
山田 95
小林
田中 85 90 80
鈴木 85
Sub 行列に並べ替え()
Dim RR As Range
Dim V0 As Variant
Dim V1 As Variant
Dim dicX As Object
Dim dicY As Object
Dim XX As String, YY As String
Dim Rmax As Long, Cmax As Long
Dim R As Long, C As Long
Dim rngDest As Range
Const jX As Integer = 3 'X列
Const jY As Integer = 2 'Y列
Const jZ As Integer = 1 'データ列
Dim i As Long, j As Long
'Dictionaryで行列各々の、値対番号を管理する
Set dicX = CreateObject("Scripting.Dictionary")
Set dicY = CreateObject("Scripting.Dictionary")
'元データ
Set RR = Range("A1").CurrentRegion
Set RR = RR.Offset(1).Resize(RR.Rows.Count - 1, 3)
V0 = RR.Value
'並べ替えた値の入れ物（行列共、最大値が既知ならその値にした方が良い）
ReDim V1(0 To UBound(V0), 0 To 255)
For i = 1 To UBound(V0)
'行の値
YY = V0(i, jY)
If Not dicY.Exists(YY) Then
'新規なら行カウントアップ
Rmax = Rmax + 1
dicY.Item(YY) = Rmax
R = Rmax
'行タイトル
V1(R, 0) = YY
Else
'既出なら
R = dicY.Item(YY)
End If
'列の値
XX = V0(i, jX)
If Not dicX.Exists(XX) Then
'新規なら列カウントアップ
Cmax = Cmax + 1
dicX.Item(XX) = Cmax
C = Cmax
'列タイトル
V1(0, C) = XX
Else
'既出なら
C = dicX.Item(XX)
End If
'値を設定する
If V1(R, C) = "" Then
V1(R, C) = V0(i, jZ)
Else
V1(R, C) = V1(R, C) & vbLf & V0(i, jZ)
End If
Next
'１箇所に２つ以上データがある場合は並べ替える(ただし文字としての並べ替え)
For i = 1 To Rmax
For j = 1 To Cmax
If InStr(V1(i, j), vbLf) >= 1 Then
V1(i, j) = join(Csort(Split(CStr(V1(i, j)), vbLf)), vbLf)
End If
Next
Next
Application.ScreenUpdating = False
'新規シートを追加して書き込み、並べ替え
Set rngDest = Worksheets.Add.Range("A1")
With rngDest.Resize(Rmax + 1, Cmax + 1)
.Value = V1
'行方向の並べ替え
With .Offset(1).Resize(.Rows.Count - 1)
.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
'列方向の並べ替え（なぜかHeader:=xlYesが効かない為このような書き方にした、行方向はこれに合わせた）
With .Offset(, 1).Resize(, .Columns.Count - 1)
.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
End With
End With
Application.ScreenUpdating = True
Set RR = Nothing
Set rngDest = Nothing
Set dicX = Nothing
Set dicY = Nothing
End Sub
Sub test()
MsgBox FilesCount(ThisWorkbook.Path, "*.xls")
End Sub
Function FilesCount(Fp As String, Ptn As String) As Long
Dim Fso As Object
Dim Fl As Object
Dim F As Object
Dim C As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fl = Fso.GetFolder(Fp)
For Each F In Fl.Files
If LCase(F.Name) Like LCase(Ptn) Then
C = C + 1
End If
Next
FilesCount = C
Set F = Nothing
Set Fl = Nothing
Set Fso = Nothing
End Function
Sub test()
MsgBox FilesCount(ThisWorkbook.Path, "xls")
End Sub
Function FilesCount(Path As String, Ext As String) As Long
Dim C As Long
Dim Dummy As String
Dummy = Dir(Path & "\*." & Ext)
Do Until Dummy = ""
C = C + 1
Dummy = Dir()
Loop
FilesCount = C
End Function
Sub test()
Const S As String = "あいabc123う"
Debug.Print LenByte(S) '12
Debug.Print LeftByte(S, 5) 'あいa
Debug.Print RightByte(S, 3) '3う
Debug.Print MidByte(S, 3, 3) 'いa
End Sub
Public Function LenByte(S As String) As Integer
LenByte = LenB(StrConv(S, vbFromUnicode))
End Function
Public Function LeftByte(ByVal S As String, L As Integer) As String
S = StrConv(S, vbFromUnicode)
S = LeftB$(S, L)
LeftByte = StrConv(S, vbUnicode)
End Function
Public Function RightByte(ByVal S As String, L As Integer) As String
S = StrConv(S, vbFromUnicode)
S = RightB$(S, L)
RightByte = StrConv(S, vbUnicode)
End Function
Public Function MidByte(ByVal S As String, P As Integer, Optional L) As String
S = StrConv(S, vbFromUnicode)
If IsMissing(L) Then
S = MidB$(S, P)
Else
S = MidB$(S, P, L)
End If
MidByte = StrConv(S, vbUnicode)
End Function
固定長テキストファイル
ＩＤ 名称 色 大きさ 重さ
0001 みかん オレンジ ８cm 100g
0002 りんご 赤 12cm 200g
0003 メロン 黄緑 23cm 800g
Sub 固定長読み込み()
Dim myStru As Variant
Dim myPos() As Integer
Dim myPath As String
Dim N As Integer
Dim rngDest As Range
Dim i As Integer
Dim D As String
'各項目の桁数
myStru = Array(8, 12, 12, 12, 4)
'各項目の左端ポジション
ReDim myPos(0 To UBound(myStru))
myPos(0) = 1
For i = 0 To UBound(myStru) - 1
myPos(i + 1) = myPos(i) + myStru(i)
Next
'読み込みファイル
myPath = ThisWorkbook.Path & "\test.txt"
N = FreeFile
'書き出し先
Set rngDest = Range("A1")
'書式を文字に変える
rngDest.Resize(, UBound(myPos) + 1).EntireColumn.NumberFormat = "@"
'読み込む
Open myPath For Input As #N
Do Until EOF(N)
'一行丸ごと読み込み
Line Input #N, D
'各項目の値に切り分けながら、書き込む
For i = 0 To UBound(myStru)
rngDest.Offset(, i).Value = MidByte(D, myPos(i), myStru(i))
Next
'書き込み先を下に移動
Set rngDest = rngDest.Offset(1)
Loop
Close #N
End Sub
Private Function MidByte(ByVal S As String, ByVal P As Integer, ByVal L As Integer) As String
'２バイト文字を２バイト、１バイト文字を１バイトとして扱うMidB関数
S = StrConv(S, vbFromUnicode)
S = MidB$(S, P, L)
MidByte = StrConv(S, vbUnicode)
End Function
Sub ReadTxt2()
Dim myPath As String
Dim N As Integer
Dim A0 As Variant
Dim A1 As Variant
Dim rngDest As Range
Dim D As String
Dim i As Long
myPath = ThisWorkbook.Path & "\test.txt"
Application.ScreenUpdating = False
N = FreeFile
Open myPath For Input As #N
D = InputB(LOF(N), N)
D = StrConv(D, vbUnicode)
Close #N
'行に分解
A0 = MsToolsC.MsSplit(D, vbCrLf)
'読み込み先
Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
For i = 1 To UBound(A0)
A1 = MsToolsC.MsSplit(CStr(A0(i)), vbTab)
rngDest.Resize(, UBound(A1)).Value = A1
Set rngDest = rngDest.Offset(1)
Next
rngDest.Worksheet.UsedRange.Replace Chr$(34), ""
Application.ScreenUpdating = True
End Sub
y x
8 -3
4.5 -2
1 -1
0.5 0
1.5 1
5.5 2
9.5 3
計算結果（y = 0.9286x^2 + 0.25x + 0.6429）
0.928571429, 0.25, 0.642857143
Sub 最小二乗法()
Dim rngY As Range
Dim rngX As Range
Dim SourceY As Variant
Dim SourceX As Variant
Dim i As Integer
Dim L As Integer
Dim U As Integer
Dim Ans As Variant
'元データ
With Range("A1").CurrentRegion
Set rngY = 項目カット(.Columns("A"))
Set rngX = 項目カット(.Columns("B"))
SourceY = rngY.Value
SourceX = rngX.Resize(,2).Value
End With
'X2乗を付加
L = LBound(SourceX): U = UBound(SourceX)
For i = L To U
SourceX(i, 2) = SourceX(i, 1) ^ 2
Next
'計算
Ans = Application.WorksheetFunction.LinEst(SourceY, SourceX)
'計算結果表示
rngX.Cells(rngX.Cells.Count + 2).Resize(, UBound(Ans)).Value = Ans
End Sub
Private Function 項目カット(R As Range) As Range
Set 項目カット = Intersect(R, R.Offset(1))
End Function
Sub シートを一まとめ()
Dim myBook As Workbook
Dim rngDest As Range
Dim Sht As Worksheet
Dim myRange As Range
Dim C As Integer
'元データブック(まとめ先が別ブックでも対応するため)
Set myBook = ActiveWorkbook
'まとめ先
Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
For Each Sht In myBook.Worksheets
'そのシートが書き込み先のシートならパス（同一ブック時の対応）
If Sht Is rngDest.Worksheet Then
Else
'コピー範囲
Set myRange = Sht.UsedRange
'二つめ以降なら項目名を除く
C = C + 1
If C >= 2 Then
Set myRange = Intersect(myRange, myRange.Offset(1))
End If
'コピー＆ペースト
myRange.Copy rngDest
'書き込み先を下に移動
Set rngDest = rngDest.Offset(myRange.Rows.Count)
End If
Next
End Sub
１ ２ １
２ ３ ２ ２
４ ４ ３
５ ６ ⇒ ４ ４
７ ７ ５
８ ９ ６
９ １１ ７ ７
１０ １２ ８
９ ９
１０
１１
１２
Sub シンクロ()
Dim rngA As Range, rngB As Range
Dim AA As Variant, BB As Variant
Dim cA As Long, cB As Long, C As Long
Dim cAmax As Long, cBmax As Long
Dim Dest As Variant
Dim A As Variant, B As Variant
Set rngA = Range("A1", Range("A65536").End(xlUp))
Set rngB = Range("B1", Range("B65536").End(xlUp))
AA = rngA.Value: BB = rngB.Value
cAmax = UBound(AA): cBmax = UBound(BB)
ReDim Dest(1 To cAmax + cBmax, 1 To 2)
cA = 1: cB = 1: C = 1
Do Until cA > cAmax Or cB > cBmax
A = AA(cA, 1): B = BB(cB, 1)
If A = B Then
Dest(C, 1) = A
cA = cA + 1
Dest(C, 2) = B
cB = cB + 1
ElseIf A < B Then
Dest(C, 1) = A
cA = cA + 1
Else
Dest(C, 2) = B
cB = cB + 1
End If
C = C + 1
Loop
Do Until cA > cAmax
A = AA(cA, 1)
Dest(C, 1) = A
cA = cA + 1
C = C + 1
Loop
Do Until cB > cBmax
B = BB(cB, 1)
Dest(C, 2) = B
cB = cB + 1
C = C + 1
Loop
'新規シートを追加して書き込み
Worksheets.Add.Range("A1").Resize(C, 2).Value = Dest
Set rngA = Nothing
Set rngB = Nothing
End Sub
Sub Bunkai()
Dim myCell As Range
Dim rngDest As Range
Dim S As String
Dim i As Integer
'元値の位置
Set myCell = Range("A1")
'書込み先の最右端
Set rngDest = Range("K2")
'「,」を取り除く
S = Replace(myCell.Text, ",", "")
'書込み先の最初の位置
Set rngDest = rngDest.Offset(, -Len(S) + 1)
'一文字づつ分解して書き込む
For i = 1 To Len(S)
rngDest.Offset(, i - 1).Value = Mid$(S, i, 1)
Next
End Sub
Sub GetChart()
Dim myChart As Chart
Dim myShape As Shape
Select Case TypeName(Selection)
Case "ChartObject", "DrawingObjects"
For Each myShape In Selection.ShapeRange
With myShape
If .Type = msoChart Then
Set myChart = ActiveSheet _
.ChartObjects(.Name).Chart
Debug.Print myChart.Name
ModifySeries myChart
End If
End With
Next
Case "Range"
'nop
Case Else
On Error Resume Next
Set myChart = ActiveChart
On Error GoTo 0
If Not myChart Is Nothing Then
Debug.Print myChart.Name
ModifySeries myChart
End If
End Select
End Sub
Sub ModifySeries(Target As Chart)
Dim mySeries As Series
With Target
Set mySeries = .SeriesCollection(1)
With mySeries
.Border.ColorIndex = 3
End With
End With
End Sub
===== ThisWorkbook =====
Option Explicit
Public ButtonCaption As String
Private Const PopupCaption As String = "▼"
Private Sub AddMenu()
Dim myButton As CommandBarButton
Dim myPopup As CommandBarPopup
Dim myCommandBar As CommandBar
Dim Ctrl As CommandBarButton
ButtonCaption = "AAA_1"
'ボタン部分の追加
Set myButton = Application.CommandBars("Worksheet Menu Bar") _
.Controls.Add(Type:=msoControlButton, temporary:=True)
With myButton
.Caption = ButtonCaption
.OnAction = ButtonCaption
.Style = msoButtonCaption
End With
'ポップアップ部分の追加
Set myPopup = Application.CommandBars("Worksheet Menu Bar") _
.Controls.Add(Type:=msoControlPopup, temporary:=True)
myPopup.Caption = PopupCaption
Set myCommandBar = myPopup.CommandBar
'ポップアップのサブメニューの追加
With myCommandBar
Set myPopup = .Controls.Add(Type:=msoControlPopup, temporary:=True)
myPopup.Caption = "AAA"
Set Ctrl = myPopup.CommandBar.Controls.Add _
(Type:=msoControlButton, temporary:=True)
With Ctrl
.Caption = "AAA_1"
.OnAction = "AAA_1"
End With
Set Ctrl = myPopup.CommandBar.Controls.Add _
(Type:=msoControlButton, temporary:=True)
With Ctrl
.Caption = "AAA_2"
.OnAction = "AAA_2"
End With
Set myPopup = .Controls.Add(Type:=msoControlPopup, temporary:=True)
myPopup.Caption = "BBB"
Set Ctrl = myPopup.CommandBar.Controls.Add _
(Type:=msoControlButton, temporary:=True)
With Ctrl
.Caption = "BBB_1"
.OnAction = "BBB_1"
End With
Set Ctrl = myPopup.CommandBar.Controls.Add _
(Type:=msoControlButton, temporary:=True)
With Ctrl
.Caption = "BBB_2"
.OnAction = "BBB_2"
End With
End With
Set Ctrl = Nothing
Set myCommandBar = Nothing
Set myPopup = Nothing
Set myButton = Nothing
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
With Application.CommandBars("Worksheet Menu Bar")
.Controls(ButtonCaption).Delete
.Controls(PopupCaption).Delete
End With
On Error GoTo 0
End Sub
Private Sub Workbook_Open()
AddMenu
End Sub
===== 標準モジュール =====
Sub AAA_1()
MsgBox "AAA_1"
ChangeButton "AAA_1", "AAA_1"
End Sub
Sub AAA_2()
MsgBox "AAA_2"
ChangeButton "AAA_2", "AAA_2"
End Sub
Sub BBB_1()
MsgBox "BBB_1"
ChangeButton "BBB_1", "BBB_1"
End Sub
Sub BBB_2()
MsgBox "BBB_2"
ChangeButton "BBB_2", "BBB_2"
End Sub
Sub ChangeButton(Cap As String, Act As String)
With Application.CommandBars("Worksheet Menu Bar") _
.Controls(ThisWorkbook.ButtonCaption)
.Caption = Cap
.OnAction = Act
End With
ThisWorkbook.ButtonCaption = Cap
End Sub
===== UserForm1 =====
Option Explicit
Private Const 落下加速度 As Double = 1000 'Point/sec^2
Private Const 減衰率 As Double = 0.8
Private Const 水平減衰率 As Double = 0.99
Private 初期高さ As Double
Private 初期Left As Double
Private flgReset As Boolean
Private Sub cmd実行_Click()
Dim 水平速度 As Double 'Point/sec
Dim 垂直初速 As Double 'Point/sec
Dim T As Double '時間
Dim Tstep As Double '計算時間間隔
Dim H0 As Double '高さ初期値
Dim H As Double '高さ
Dim L As Double 'Left位置
Dim 進行方向 As Integer '1.右向き -1.左向き
Dim T0 As Double '前回落下時間
Dim C As Integer '落下時間が同じであった回数
Dim 有効幅 As Double 'フォームの有効幅
Dim 有効高さ As Double 'フォームの有効高さ
水平速度 = 100
Tstep = 0.01
進行方向 = 1
flgReset = False
With Me.lblボール
'-3は右端の影の部分
有効幅 = Me.Width - .Width - 3
'-18はトップのタイトルの高さ
有効高さ = Me.Height - .Height - 18
'デザイン時の位置取得
.Top = 初期高さ
.Left = 初期Left
'H0:落下高さ計算時の初期高さ
H0 = .Top
'値の保持と計算はフォームの一番下を原点0として行う
H0 = 有効高さ - H0
'Leftは、左右の等速運動（減衰は入れるが）で前の値に _
加算してゆく形としたのでL0は無し、上下は上頂点と下の _
跳ね返り時に各々時間をリセットし初期高さからの位置を _
計算しているのでH0を設定している
L = .Left
Do
'落下
T = 0
H = H0
Do
'時間待ち
Waitt Tstep
T = T + Tstep
'落下高さ、跳ね返り点を越えたら0とする
H = 高さ(H0, 0, T)
If H < 0 Then
H = 0
End If
'水平位置、左右を越えたら超えた分逆の跳ね返った位置にする
L = L + 水平速度 * Tstep * 進行方向
If L > 有効幅 Then
進行方向 = -1
L = 有効幅 - (L - 有効幅)
ElseIf L < 0 Then
進行方向 = 1
L = -L
End If
'ボールの移動、Topはコントロールの座標に変換して設定
.Top = 有効高さ - H
.Left = L
Loop While H > 0
水平速度 = 水平速度 * 水平減衰率
'落下時間が収束してしまったらその回数をカウントする
If T0 = T Then
C = C + 1
Else
T0 = T
End If
'落下時間が収束し規定回数を超えたら
If C > 5 Then
'ボールは下に固定し
.Top = 有効高さ
Do
'水平方向の動きだけにする
L = L + 水平速度 * Tstep * 進行方向
If L > 有効幅 Then
進行方向 = -1
L = 有効幅 - (L - 有効幅)
ElseIf L < 0 Then
進行方向 = 1
L = -L
End If
.Left = L
Waitt Tstep
水平速度 = 水平速度 * 水平減衰率
'水平速度が規定値未満になったら終わる
If Abs(水平速度) < 1 Then
Exit Do
End If
Loop
Exit Do
End If
If flgReset Then Exit Do
'跳ね返り位置での本当の経過時間の平均
T = T - Tstep / 2
'上昇
垂直初速 = -落下加速度 * T * 減衰率
T = 0
H = 0
'垂直方向のスピードが0以下つまり上向きの間
Do While 垂直初速 + 落下加速度 * T <= 0
.Top = 有効高さ - H
.Left = L
Waitt Tstep
T = T + Tstep
'ここでの引数「初期高さ」は0
H = 高さ(0, 垂直初速, T)
L = L + 水平速度 * Tstep * 進行方向
If L > 有効幅 Then
進行方向 = -1
L = 有効幅 - (L - 有効幅)
ElseIf L < 0 Then
進行方向 = 1
L = -L
End If
Loop
'頂点の折り返し位置での本当の経過時間の平均
T = T - Tstep / 2
H0 = 高さ(0, 垂直初速, T)
If flgReset Then Exit Do
Loop
End With
End Sub
Private Function 高さ(初期高さ As Double, _
垂直初速 As Double, _
T As Double) As Double
't秒経過時の高さを返す(垂直初速：下向きを＋とする)
Dim H As Double
H = 落下加速度 * T * T / 2
H = H + 垂直初速 * T
高さ = 初期高さ - H
End Function
Private Sub Waitt(T As Double)
Dim T1 As Double
T1 = Timer + T
Do While Timer < T1
DoEvents
Loop
End Sub
Private Sub cmdReset_Click()
flgReset = True
With Me.lblボール
.Top = 初期高さ
.Left = 初期Left
End With
End Sub
Private Sub UserForm_Initialize()
With Me.lblボール
初期高さ = .Top
初期Left = .Left
End With
End Sub
===== ThisWorkbook =====
Option Explicit
Private WithEvents myApp As Application
Private Sub myApp_WorkbookBeforeSave(ByVal Wb As Excel.Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
番号取得と設定 Wb
End Sub
Private Sub Workbook_Open()
Set myApp = Application
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myApp = Nothing
End Sub
Private Sub 番号取得と設定(Wb As Workbook)
Dim Target As Range
Dim myPath As String
Dim N As Integer
Dim Number As Long
If Wb.Name = ThisWorkbook.Name Then Exit Sub
If LCase(Wb.Name) Like "*.xlt" Then Exit Sub
If Not Wb.Name Like "発注書*" Then Exit Sub
'連番記入場所
Set Target = Wb.Worksheets("Sheet1").Range("A1")
If Target.Value <> "" Then Exit Sub
myPath = ThisWorkbook.Path & "\最終発注番号.txt"
N = FreeFile
Open myPath For Input As #N
Input #N, Number
Close #N
Number = Number + 1
N = FreeFile
Open myPath For Output As #N
Print #N, Number
Close #N
Target.Value = Number
End Sub
Sub ReadCsv3()
'CSVファイルを任意のセル位置へ読み込む
Const myPath As String = "test.csv"
Dim N As Integer
Dim D As String
Dim VV As Variant
Dim V As Variant
Dim A As Variant
Dim R As Range
'読み込み先
Set R = Range("A1")
N = FreeFile
Open myPath For Input As #N
D = InputB(LOF(N), N)
D = StrConv(D, vbUnicode)
Close #N
VV = Split(D, vbCrLf)
For Each V In VV
A = Split(CStr(V), ",")
R.Resize(, UBound(A) + 1).Value = A
Set R = R.Offset(1)
Next
End Sub
Sub グループ罫線()
'A列の同一値基準で、A列からD列のセル範囲を罫線で囲む
Dim S As Range
Dim E As Range
Dim SE As Range
Set S = Range("A1")
Set E = S
Do Until S.Value = ""
Set E = E.Offset(1)
If E.Value = E.Offset(-1).Value Then
Else
Set SE = Range(S, E.Offset(-1))
SE.Resize(, 4).BorderAround Weight:=xlThin
Set S = E
End If
Loop
End Sub
===== UserForm1 =====
Option Explicit
Private myChecks() As cCheckBox
Private C As Integer
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim myCtrl As MSForms.Control
C = C + 1
ReDim Preserve myChecks(1 To C)
Set myChecks(C) = New cCheckBox
With Me
Set myCtrl = .Controls.Add("Forms.CheckBox.1")
With myCtrl
.Name = "CheckBox" & C
.Left = Image1.Left + X - 5
.Top = Image1.Top + Y - 5
.Width = 12
.Height = 12
.BackStyle = fmBackStyleTransparent
.Caption = ""
.Value = True
End With
End With
Set myChecks(C).ChkBox = myCtrl
myChecks(C).ID = C
myChecks(C).Name = myCtrl.Name
End Sub
Private Sub UserForm_Terminate()
Dim i As Integer
On Error Resume Next
For i = LBound(myChecks) To UBound(myChecks)
Set myChecks(i) = Nothing
Next
Erase myChecks
End Sub
Public Sub DeleteCheckBox(ID As Integer, Namae As String)
Me.Controls.Remove Namae
Set myChecks(ID) = Nothing
End Sub
===== cCheckBox =====
Option Explicit
Public WithEvents ChkBox As MSForms.CheckBox
Private myID As Integer
Private myName As String
Public Property Let ID(IDNo As Integer)
myID = IDNo
End Property
Public Property Let Name(Namae As String)
myName = Namae
End Property
Private Sub ChkBox_Click()
If ChkBox.Value = False Then
UserForm1.DeleteCheckBox myID, myName
End If
End Sub
Private Sub Class_Terminate()
Set ChkBox = Nothing
End Sub
===== UserForm1 =====
Option Explicit
Private myTxt() As cTxtBox
Private Sub CommandButton1_Click()
Dim myBox As MSForms.Control
Dim i As Integer
Dim X As Single, Y As Single
Dim C As Integer
KillTxtBox
C = Val(Me.TextBox1.Value)
ReDim myTxt(1 To C)
X = 20: Y = 50
For i = 1 To C
Set myBox = Me.Controls.Add _
("Forms.TextBox.1", "txt" & i, True)
With myBox
.Left = X: .Top = Y
Y = Y + .Height + 10
End With
Set myTxt(i) = New cTxtBox
Set myTxt(i).TxtBox = myBox
Next
End Sub
Private Sub KillTxtBox()
Dim i As Integer
On Error Resume Next
For i = 1 To UBound(myTxt)
Me.Controls.Remove myTxt(i).Name
Set myTxt(i) = Nothing
Next
On Error GoTo 0
Erase myTxt
End Sub
Private Sub UserForm_Terminate()
KillTxtBox
End Sub
===== cTxtBox =====
Option Explicit
Private WithEvents Txt As MSForms.TextBox
Private Ctrl As MSForms.Control
Public Property Set TxtBox(Box As MSForms.Control)
Set Txt = Box
Set Ctrl = Box
End Property
Public Property Get Name() As String
Name = Ctrl.Name
End Property
Private Sub Class_Terminate()
Set Txt = Nothing
Set Ctrl = Nothing
End Sub
Private Sub Txt_Change()
If Txt.Value = "" Then
MsgBox Ctrl.Name & "：なし"
End If
End Sub
===== UserForm1 =====
Option Explicit
Private myList() As cListBox
Private Sub UserForm_Initialize()
Dim C As Integer
Dim L As MSForms.Control
For Each L In Me.Controls
If TypeOf L Is MSForms.ListBox Then
C = C + 1
ReDim Preserve myList(1 To C)
Set myList(C) = New cListBox
Set myList(C).List = L
Set myList(C).Ctrl = L
End If
Next
End Sub
Private Sub UserForm_Terminate()
Dim i As Integer
On Error Resume Next
For i = LBound(myList) To UBound(myList)
Set myList(i) = Nothing
Next
On Error GoTo 0
Erase myList
End Sub
===== cListBoxクラス =====
Option Explicit
Public WithEvents List As MSForms.ListBox
'NameプロパティはListBoxクラスには含まれないため別に定義する
Public Ctrl As MSForms.Control
Private Sub List_Click()
With List
MsgBox .Value
End With
With Ctrl
MsgBox .Name
End With
End Sub
Sub ReadCSV()
Dim myPath As String
Dim Fname As String
Dim N As Integer
Dim rngDest As Range
Dim myArray0 As Variant
Dim myArray As Variant
Dim D As String
Dim i As Integer
myPath = ThisWorkbook.Path & "\"
Set rngDest = Worksheets("Sheet1").Range("A1")
Application.ScreenUpdating = False
Fname = Dir(myPath & "*.csv")
Do Until Fname = ""
N = FreeFile
Open myPath & Fname For Input As #N
D = InputB(LOF(N), N)
D = StrConv(D, vbUnicode)
Close #N
'先頭行にファイル名挿入
'rngDest.Value = Fname
'Set rngDest = rngDest.Offset(1)
myArray0 = Split(D, vbCrLf) '全体を行に分割
For i = 0 To UBound(myArray0)
myArray = Split(CStr(myArray0(i)), ",") '各行を項目に分割
rngDest.Resize(1, UBound(myArray) + 1).Value = myArray
Set rngDest = rngDest.Offset(1)
Next
Fname = Dir()
Loop
Application.ScreenUpdating = True
Set rngDest = Nothing
End Sub
Sub CSVをまとめる()
Dim myPath As String
Dim Nin As Integer
Dim Nout As Integer
Dim Fname As String
Dim D As String
Dim Fc As Integer 'FileCount
Dim Lc As Integer 'LineCount
myPath = ThisWorkbook.Path & "\"
Nout = FreeFile
Open myPath & "Out.txt" For Output As #Nout
Fname = Dir(myPath & "*.csv")
Do Until Fname = ""
Fc = Fc + 1
Lc = 0
Nin = FreeFile
Open myPath & Fname For Input As #Nin
Do Until EOF(Nin)
Line Input #Nin, D
Lc = Lc + 1
'１ファイルめの１行目のみタイトルとして出力
If Lc = 1 Then
If Fc = 1 Then
Print #Nout, D
End If
Else
'２行目以降はすべて出力
Print #Nout, D
End If
Loop
Close #Nin
Fname = Dir()
Loop
Close #Nout
End Sub
Ｂ Ｅ Ａ Ａ
Ｃ Ｇ Ｂ
Ｄ Ａ ⇒ Ｃ Ｃ
Ｆ Ｃ Ｄ
Ａ Ｅ
Ｆ
Ｇ
Sub シンクロ並べ替え()
Dim Dic As Object
Dim rngA As Range
Dim rngB As Range
Dim rngDest As Range
Dim myCell As Range
Dim K As String
Dim Kys As Variant
Dim Idx As Variant
Dim V As Variant
Dim i As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Set rngA = Range("A1", Range("A65536").End(xlUp))
Set rngB = Range("B1", Range("B65536").End(xlUp))
Set rngDest = Range("D1")
For Each myCell In rngA.Cells
K = myCell.Value
Dic.Item(K) = 1
Next
For Each myCell In rngB.Cells
K = myCell.Value
Dic.Item(K) = Dic.Item(K) + 2
Next
Kys = Dic.keys
Idx = MsCombSortI(Kys) 'キーが文字の場合
'Idx = MsCombSortI(StoV(Kys)) 'キーが数値の場合
For i = LBound(Idx) To UBound(Idx)
K = Kys(Idx(i))
V = Dic.Item(K)
If V = 1 Or V = 3 Then
rngDest.Value = K
End If
If V = 2 Or V = 3 Then
rngDest.Offset(, 1).Value = K
End If
Set rngDest = rngDest.Offset(1)
Next
Set myCell = Nothing
Set rngDest = Nothing
Set rngB = Nothing
Set rngA = Nothing
Set Dic = Nothing
End Sub
Private Function StoV(S As Variant) As Variant
'String()をDouble()に変換、一次元限定
Dim V() As Double
Dim L As Long, U As Long
Dim i As Long
L = LBound(S): U = UBound(S)
ReDim V(L To U)
For i = L To U
V(i) = CDbl(S(i))
Next
StoV = V
End Function
===== ThisWorkbook =====
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)
'ワークシート名と項目名でチェック
If Sh.Name = "定価表" And 項目名3(Target) = "仕様コード" Then
MsgBox "OK"
Cancel = True
End If
End Sub
Private Function 項目名(Target As Range) As String
'アクティブセル領域の第一行めの値を返す
Dim myCell As Range
With Target
Set myCell = Intersect(.CurrentRegion, .EntireColumn)
Set myCell = myCell.Cells(1)
End With
項目名 = myCell.Value
End Function
Private Function 項目名2(Target As Range) As String
'罫線で囲まれた表の第一行めの値を返す _
'（上方向に見て、上罫線がある最初のセルの値を返す）
Dim myCell As Range
Set myCell = Target
Do Until myCell.Row = 1 Or _
myCell.Borders(xlEdgeTop).LineStyle = xlContinuous
Set myCell = myCell.Offset(-1, 0)
Loop
If myCell.Borders(xlEdgeTop).LineStyle = xlContinuous Then
項目名2 = myCell.Value
Else
項目名2 = ""
End If
End Function
Private Function 項目名3(Target As Range) As String
'上方向に見て、数字でない文字が入力されている最初のセルの値を返す
Dim myCell As Range
Set myCell = Target
Do Until myCell.Row = 1 Or Not IsNumeric(myCell.Value)
Set myCell = myCell.Offset(-1, 0)
Loop
If Not IsNumeric(myCell.Value) Then
項目名3 = myCell.Value
Else
項目名3 = ""
End If
End Function
Sub Test
Msgbox 半角英数字("123abc")
Msgbox 半角英数字("123あabc")
End Sub
Function 半角英数字(S As String) As Boolean
If S = "" Then 半角英数字 = False: Exit Function
If S Like "*[!A-Za-z0-9]*" Then
半角英数字 = False
Else
半角英数字 = True
End If
End Function
Sub myNumber()
Dim rngTop As Range
Dim rngEnd As Range
Dim myColumn As Range
Dim myCell As Range
Dim C As Long
Set rngTop = Range("G1")
Set rngEnd = Range("G65536").End(xlUp)
Set myColumn = Range(rngTop, rngEnd)
Set myColumn = myColumn.SpecialCells(xlCellTypeConstants)
C = 1
For Each myCell In myColumn.Cells
With myCell
If .Value = 1 Then
.Offset(, -6).Value = C
C = C + 1
End If
End With
Next
End Sub
Sub test()
Dim myPath As String
Dim N As Integer
Dim LineData As String
Dim rngDest As Range
Dim myArray As Variant
myPath = ThisWorkbook.Path & "\test.txt"
N = FreeFile
Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
Open myPath For Input As #N
Do While Not EOF(N)
Line Input #N, LineData
myArray = Split(Replace(LineData, Chr$(34), ""), vbTab)
With rngDest.Resize(1, UBound(myArray) + 1)
.NumberFormat = "@"
.Value = myArray
End With
Set rngDest = rngDest.Offset(1)
Loop
Close #N
End Sub
Sub Books2Sheet()
Dim rngDest As Range
Dim myPath As String
Dim myBookName As String
Dim mySheet As Worksheet
myPath = ThisWorkbook.Path & "\"
myBookName = Dir(myPath & "*.xls")
If myBookName = "" Then Exit Sub
Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
Do Until myBookName = ""
If myBookName = ThisWorkbook.Name Then
Else
With Workbooks.Open(myPath & myBookName)
For Each mySheet In .Worksheets
With mySheet.UsedRange
.Copy rngDest
Set rngDest = rngDest.Offset(.Rows.Count)
End With
Next
.Close False
End With
End If
myBookName = Dir()
Loop
Msgbox "完了！"
End Sub
Sub test()
Dim RR As Range
Set RR = ColTrim(Selection)
If RR Is Nothing Then
MsgBox "Nothing"
Else
RR.Select
End If
End Sub
Private Function ColTrim(ByVal RR As Range) As Range
'一列の上下の空白セルを取り除いて返す、すべて空白ならNothingを返す
Dim T As Range, B As Range
If RR Is Nothing Then Exit Function
Set RR = RR.Columns(1)
Set T = RR.Cells(1)
Set B = RR.Cells(RR.Cells.Count)
If T.Value = "" Then
Set T = T.End(xlDown)
End If
If B.Value = "" Then
Set B = B.End(xlUp)
End If
If B.Row >= T.Row Then
Set ColTrim = Range(T, B)
Else
Set ColTrim = Nothing
End If
End Function
Sub test()
Dim RR As Range
Set RR = Range("A1:E5")
TrimTitle2(RR).Select
End Sub
Private Function TrimTitle2(R As Range, Optional N As Integer = 1) As Range
'表の左n列を取り去って返す
Set TrimTitle2 = Intersect(R, R.Offset(,N))
End Function
Sub test()
Dim RR As Range
Set RR = Range("A1:E5")
TrimTitle(RR, 2).Select
End Sub
Private Function TrimTitle(R As Range, Optional N As Integer = 1) As Range
'表の上n行を取り去って返す
Set TrimTitle = Intersect(R, R.Offset(N))
End Function
===== ThisWorkbook =====
Option Explicit
Private Sub Workbook_Open()
AddMenu
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
DeleteMenu
End Sub
===== 標準モジュール =====
Option Explicit
'要変更箇所１：プロジェクト名
Private Const MenuCaption As String = "Menu-1" '要変更箇所２：メニュー名
Public Sub AddMenu()
'専用メニューの追加
Dim Ctrl As CommandBarControl
Dim myCtrl As CommandBarControl
Dim myBar As CommandBar
Dim Flag As Boolean
'ワークシートメニューバー
With Application.CommandBars("Worksheet Menu Bar")
Flag = False
'専用メニューが既にあるか確認
For Each Ctrl In .Controls
If Ctrl.Caption = MenuCaption Then
Flag = True
Exit For
End If
Next
If Not Flag Then
'無い場合は追加する
Set myCtrl = .Controls.Add(Type:=msoControlPopup, Temporary:=True)
myCtrl.Caption = MenuCaption
Set myBar = myCtrl.CommandBar
AddSubMenu myBar
End If
End With
'ショートカットメニュー(Cell)
With Application.CommandBars("Cell")
Flag = False
'専用メニューが既にあるか確認
For Each Ctrl In .Controls
If Ctrl.Caption = MenuCaption Then
Flag = True
Exit For
End If
Next
If Not Flag Then
'無い場合は追加する
Set myCtrl = .Controls.Add(Type:=msoControlPopup, Before:=1, Temporary:=True)
.Controls(2).BeginGroup = True
myCtrl.Caption = MenuCaption
Set myBar = myCtrl.CommandBar
AddSubMenu myBar
End If
End With
End Sub
Private Sub AddSubMenu(myBar As CommandBar) '要変更箇所３
With myBar.Controls
With .Add(msoControlButton, 1)
.Caption = "SubMenuA"
.OnAction = "SubMenuA"
End With
With .Add(msoControlButton, 1)
.Caption = "SubMenuB"
.OnAction = "SubMenuB"
End With
With .Add(msoControlButton, 1)
.BeginGroup = True
.Caption = "終了(&X)"
'プロジェクト名.モジュール名.プロシージャ名 とすることを強く推奨します
.OnAction = "Pro1.Module1.終了"
End With
End With
End Sub
Private Sub SubMenuA() '要変更箇所４
MsgBox "I am SubMenuA"
End Sub
Private Sub SubMenuB() '要変更箇所４
MsgBox "I am SubMenuB"
End Sub
Private Sub 終了()
DeleteMenu
ThisWorkbook.Close
End Sub
Public Sub DeleteMenu()
'専用メニューの削除
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls(MenuCaption).Delete
Application.CommandBars("Cell").Controls(MenuCaption).Delete
On Error GoTo 0
End Sub
===== ThisWorkbookモジュール =====
Option Explicit
Private Const myBarName As String = "my&Menu"
Private Sub Workbook_Open()
Dim myPopUp As CommandBarPopup
Dim myBar As CommandBar
Dim myButton As CommandBarButton
DeleteMenu
Set myPopUp = Application.CommandBars("Worksheet Menu Bar") _
.Controls.Add(Type:=msoControlPopup, temporary:=True)
With myPopUp
.Caption = myBarName
Set myBar = .CommandBar
End With
Set myButton = myBar.Controls.Add(Type:=msoControlButton)
With myButton
.Caption = "SubMenu&1"
.OnAction = "SubMenu1"
End With
Set myButton = Nothing
Set myBar = Nothing
Set myPopUp = Nothing
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
DeleteMenu
End Sub
Private Sub DeleteMenu()
On Error Resume Next
Application.CommandBars("WorkSheet Menu Bar").Controls(myBarName).Delete
On Error GoTo 0
End Sub
===== 標準モジュール =====
Sub SubMenu1()
MsgBox "Hello World!"
End Sub
Sub グラフをウィンドウで表示する()
Dim myRange As Range
Dim myChartOBJ As ChartObject
Set myRange = ActiveCell.CurrentRegion
With Charts.Add
.ChartType = xlColumnClustered
.SetSourceData Source:=myRange
.Location Where:=xlLocationAsObject, _
Name:=myRange.Worksheet.Name
End With
With myRange.Worksheet
Set myChartOBJ = .ChartObjects(.ChartObjects.Count)
End With
With myChartOBJ
.Chart.ShowWindow = True
.Delete
End With
End Sub
Sub グラフの縦横比率を1対1にする()
Dim myChart As Chart
Dim 横pP As Double
Dim 縦pP As Double
Dim myAxis As Axis
Set myChart = ActiveChart
With myChart
'フォント自動サイズ調整Off
.ChartArea.AutoScaleFont = False
'横、単位当たりのポイント長さ
Set myAxis = .Axes(xlCategory)
横pP = .PlotArea.InsideWidth / (myAxis.MaximumScale - myAxis.MinimumScale)
'縦、単位当たりのポイント長さ
Set myAxis = .Axes(xlValue)
縦pP = .PlotArea.InsideHeight / (myAxis.MaximumScale - myAxis.MinimumScale)
With .PlotArea
'長い方を短くする
If 横pP > 縦pP Then
'横の方が長ければ
.Width = .Width - .InsideWidth * (1 - 縦pP / 横pP)
Else
'縦の方が長ければ
.Height = .Height - .InsideHeight * (1 - 横pP / 縦pP)
End If
End With
End With
End Sub
Sub Start2()
Dim myTime As Integer
Dim i As Integer
Dim T0 As Single
Dim T1 As Single
myTime = 60
T0 = Timer
For i = myTime To 1 Step -1
T1 = T0 + myTime - i + 1
Range("A1").Value = i
Do While Timer < T1
DoEvents
Loop
Next
Range("A1").Value = 0
MsgBox "お時間でごんす。"
End Sub
===== UserForm1 =====
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 40
'下
With Me.ComboBox1
If .ListIndex = .ListCount - 1 Then
.ListIndex = 0
KeyCode = 0
End If
End With
Case 38
'上
With Me.ComboBox1
If .ListIndex = 0 Then
.ListIndex = .ListCount - 1
KeyCode = 0
End If
End With
End Select
End Sub
系列名 X Y
ａ 1 2
ｂ 2 5
ｃ 3 3
ｄ 4 6
ｅ 5 1
Sub CreateChart()
Dim myChartOBJ As ChartObject
Dim myChart As Chart
Dim myTable As Range
Dim L As Double
Dim T As Double
Dim myRow As Range
Dim mySeries As Series
'元データ
Set myTable = Range("A2", Range("A65536").End(xlUp)).Resize(, 3)
'散布図を描く場所
With myTable
L = .Left + .Width
T = .Top
End With
'埋め込みグラフを作る
Set myChartOBJ = ActiveSheet.ChartObjects.Add(L, T, 400, 400)
Set myChart = myChartOBJ.Chart
With myChart
.ChartType = xlXYScatter '散布図
.ChartArea.AutoScaleFont = False
For Each myRow In myTable.Rows
'一行一系列
.SeriesCollection.Add Source:=myRow
Set mySeries = .SeriesCollection(.SeriesCollection.Count)
'系列名、X、Y値をあらためて指定
With mySeries
.Name = myRow.Cells(1).Value
.XValues = myRow.Cells(2)
.Values = myRow.Cells(3)
End With
Next
End With
End Sub
Sub CheckTimeStamp()
Dim myPath As String
Dim myFname As String
Dim myTimeStamp As Date
Dim TimeA As Date
Dim TimeB As Date
myPath = ThisWorkbook.Path
TimeA = #12/27/04 1:00:00 AM#
TimeB = #12/27/04 3:00:00 AM#
myFname = Dir(myPath & "\*.*")
Do While myFname <> ""
myTimeStamp = FileDateTime(myPath & "\" & myFname)
If myTimeStamp >= TimeA And myTimeStamp <= TimeB Then
Debug.Print myFname, myTimeStamp
End If
myFname = Dir()
Loop
End Sub
Sub test()
With CreateObject("WScript.Shell")
.Run "notepad.exe", , True
MsgBox "処理1終了"
.Run "CALC.EXE", , True
MsgBox "処理2終了"
End With
End Sub
Private Sub test()
Dim Fld As String
'Fld = フォルダ選択
Fld = フォルダ選択(Title:="選択してね", RootFolder:="c:\")
If Fld = "" Then
MsgBox "Cancel or Error", vbExclamation
Else
MsgBox Fld
End If
End Sub
'選択したフォルダのフルパスを返す、キャンセル又はエラーなら""を返す
Public Function フォルダ選択(Optional Title As String = "フォルダを選択して下さい。", _
Optional RootFolder As Variant) As String
'参照設定するなら、Microsoft Shell Controls And Automationに
Dim Shl As Object 'Shell32.Shell
Dim Fld As Object 'Folder
Dim strFld As String
Set Shl = CreateObject("Shell.Application")
'1:コントロールパネルなどの余分なもの非表示 512:新規フォルダ作成ボタン非表示
If IsMissing(RootFolder) Then
Set Fld = Shl.BrowseForFolder(0, Title, 1 + 512)
Else
Set Fld = Shl.BrowseForFolder(0, Title, 1 + 512, RootFolder)
End If
strFld = ""
If Not Fld Is Nothing Then
On Error Resume Next
strFld = Fld.Self.Path
If strFld = "" Then
strFld = Fld.Items.Item.Path
End If
On Error GoTo 0
End If
If InStr(strFld, "\") = 0 Then strFld = ""
フォルダ選択 = strFld
Set Fld = Nothing
Set Shl = Nothing
End Function
Sub ReplaceText()
Dim myShape As Shape
Const Org As String = "Text"
Const After As String = "テキスト"
Dim i As Integer
On Error Resume Next
For Each myShape In ActiveSheet.Shapes
With myShape.TextFrame.Characters
i = InStr(.Text, Org)
If i >= 1 Then
.Text = Left$(.Text, i - 1) & After & Mid$(.Text, i + Len(Org))
End If
End With
Next
On Error GoTo 0
Set myShape = Nothing
End Sub
===== ThisWorkbookモジュール =====
'ブックに添付したツールバーの名前
Private Const myBarName As String = "myBar"
Private myBar As CommandBar
Private Sub Workbook_Open()
Set myBar = Application.CommandBars(myBarName)
myBar.Visible = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
myBar.Delete
Set myBar = Nothing
End Sub
Private Sub Workbook_Activate()
myBar.Visible = True
End Sub
Private Sub Workbook_Deactivate()
On Error Resume Next
myBar.Visible = False
On Error GoTo 0
End Sub
===== ThisWorkbook =====
Option Explicit
Private myButtonName As String
Private Sub Workbook_Open()
Dim myButton As CommandBarButton
myButtonName = """" & "付きCSV保存"
With Application.CommandBars("Cell")
Set myButton = .Controls.Add(before:=1, temporary:=True)
With myButton
.Caption = myButtonName
.OnAction = "二重引用符付きCSVで保存"
End With
.Controls(2).BeginGroup = True
End With
Set myButton = Nothing
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.CommandBars("Cell").Controls(myButtonName).Delete
On Error GoTo 0
End Sub
===== 標準モジュール =====
Sub 二重引用符付きCSVで保存()
Dim myPath As String
Dim tmpPath As String
Dim N As Integer
Dim myRange As Range
Dim i As Long
Dim j As Long
Dim Qt As String
Qt = Chr$(34)
Set myRange = ActiveSheet.UsedRange
With myRange
myPath = .Worksheet.Parent.FullName
tmpPath = .Worksheet.Parent.Path & "\Temp.csv"
N = FreeFile
Open tmpPath For Output As #N
For i = 1 To .Rows.Count
Print #N, Qt; .Cells(i, 1).Text; Qt;
For j = 2 To .Columns.Count
Print #N, ","; Qt; .Cells(i, j).Text; Qt;
Next j
Print #N, ""
Next i
Close #N
.Worksheet.Parent.Close False
Kill myPath
Name tmpPath As myPath
End With
End Sub
Option Explicit
Private Const CombName As String = "学校List"
Sub Sett()
Dim myList As CommandBarComboBox
Set myList = Application.CommandBars("Worksheet Menu Bar"). _
Controls.Add(Type:=msoControlComboBox, Temporary:=True)
With myList
.Caption = CombName
.AddItem "小学校"
.AddItem "中学校"
.AddItem "高等学校"
.OnAction = "Exec"
End With
End Sub
Sub Resett()
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls(CombName).Delete
On Error GoTo 0
End Sub
Sub Exec()
MsgBox CommandBars.ActionControl.Text
End Sub
Sub SumFiles()
Dim myBook As Workbook
Dim destBook As Workbook
Dim myName As String
Dim myPath As String
Set destBook = Workbooks.Add
myPath = "フォルダA\"
myName = Dir(myPath & "10*.xls")
Do While myName <> ""
Set myBook = Workbooks.Open(myPath & myName)
myBook.Worksheets.Copy destBook.Worksheets(1)
myBook.Close False
myName = Dir()
Loop
Set myBook = Nothing
Set destBook = Nothing
End Sub
Sub グループ処理2() '※終了条件＝""
Dim S As Range
Dim E As Range
Set S = Range("A2")
Set E = S
Do Until S.Value = ""
Set E = E.Offset(1)
If E.Value = E.Offset(-1).Value Then
Else
Debug.Print S.Row, E.Offset(-1).Row
Set S = E
End If
Loop
End Sub
Sub グループ処理3() '※終了条件＝最終行
Dim S As Range
Dim E As Range
Dim maxRow As Long
maxRow = Range("A65536").End(xlUp).Row
Set S = Range("A2")
Set E = S
Do Until S.Row > maxRow
Set E = E.Offset(1)
If E.Value = E.Offset(-1).Value Then
Else
Debug.Print S.Row, E.Offset(-1).Row
Set S = E
End If
Loop
End Sub
Sub グループ処理4() '※配列の場合
Dim S As Long
Dim E As Long
Dim Ary As Variant
Dim Flg As Boolean
Ary = Array(1, 2, 2, 3, 3, 3, 4)
S = LBound(Ary)
E = S
Do Until S > UBound(Ary)
E = E + 1
If E > UBound(Ary) Then
Flg = True
Else
If Ary(E) = Ary(E - 1) Then
Flg = False
Else
Flg = True
End If
End If
If Flg Then
Debug.Print S, E - 1
S = E
End If
Loop
End Sub
学年 クラス 名前 成績
1 1 日本太郎 90
1 2 平成次郎 75
1 2 日本花子 66
3 1 平成花子 47
5 3 村木美子 100
5 3 山田一郎 99
↓
学年 クラス 名前 成績
1 1 日本太郎 90
平均 90
最高 90
標準偏差 0
1 2 平成次郎 75
1 2 日本花子 66
平均 70.5
最高 75
標準偏差 4.5
3 1 平成花子 47
平均 47
最高 47
標準偏差 0
5 3 村木美子 100
5 3 山田一郎 99
平均 99.5
最高 100
標準偏差 0.5
Sub クラス毎関数挿入()
Dim rngTop As Range
Dim rngBottom As Range
Dim rngCalc As Range
Set rngTop = Range("A2")
Set rngBottom = rngTop
Do Until rngTop.Value = ""
Set rngBottom = rngBottom.Offset(1)
With rngBottom
If .Value = .Offset(-1, 0).Value And _
.Offset(0, 1).Value = .Offset(-1, 1).Value Then
'nop
Else
'3行挿入
.Resize(3).EntireRow.Insert
'計算対象範囲
Set rngCalc = Range(rngTop, .Offset(-4)).Offset(, 3)
'平均
.Offset(-3, 2).Formula = "平均"
.Offset(-3, 3).Formula = "=AVERAGE(" & rngCalc.Address(0, 0) & ")"
'最高
.Offset(-2, 2).Formula = "最高"
.Offset(-2, 3).Formula = "=MAX(" & rngCalc.Address(0, 0) & ")"
'標準偏差
.Offset(-1, 2).Formula = "標準偏差"
.Offset(-1, 3).Formula = "=STDEVP(" & rngCalc.Address(0, 0) & ")"
Set rngTop = rngBottom
End If
End With
Loop
Set rngTop = Nothing
Set rngBottom = Nothing
Set rngCalc = Nothing
End Sub
111 aaa bbb
222 ccc
333 ddd eee fff ggg
444 hhh iii
555 jjj
↓
111 aaa
111 bbb
222 ccc
333 ddd
333 eee
333 fff
333 ggg
444 hhh
444 iii
555 jjj
Sub Sort()
Dim myColumn As Range
Dim myCell As Range
Dim Temp As Range
Dim C As Long
Dim i As Long
Dim j As Long
Set myColumn = ActiveSheet.UsedRange.Columns(1)
For i = myColumn.Rows.Count To 1 Step -1
Set myCell = myColumn.Cells(i)
With myCell
Set Temp = .End(xlToRight)
C = Temp.Column - .Column - 1
If C >= 1 Then
.Offset(1, 0).EntireRow.Resize(C).Insert
For j = 1 To C
.Offset(j, 0).Value = .Value
.Offset(j, 1).Value = .Offset(0, j + 1).Value
.Offset(0, j + 1).Value = ""
Next
End If
End With
Next
End Sub
A1:A15 ==> B1:F4
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ
１ スタート あ い う え お
２ あ あ う お
３ う あ い う え
４ お い お
５ エンド
６ スタート
７ あ
８ え
９ い
10 う
11 エンド
12 スタート
13 い
14 お
15 エンド
Sub グループ毎に縦から横に並べ替え()
Dim A As Variant, B As Variant
Dim V As Variant
Dim i As Integer
Dim Dic As Object
Dim R As Integer, C As Integer
'処理データ取得
A = Range("A1", Range("A1").End(xlDown)).Value
'各データに対する列番号を設定
B = Csort2(A) '並べ替え
Set Dic = CreateObject("Scripting.Dictionary")
C = 1
For i = 1 To UBound(B)
V = B(i, 1)
Select Case V
Case "スタート", "エンド"
Case Else
If Not Dic.Exists(V) Then
C = C + 1
Dic.Item(V) = C
End If
End Select
Next
'総括（項目行）表示
Cells(1, 2).Resize(1, Dic.Count).Value = Dic.Keys
'各データ表示
R = 1
For i = 1 To UBound(A)
V = A(i, 1)
Select Case V
Case "スタート"
R = R + 1
Case "エンド"
Case Else
Cells(R, Dic.Item(V)).Value = V
End Select
Next
Set Dic = Nothing
End Sub
Private Function Csort2(ByVal Ary As Variant) As Variant
'１列のみの２次元配列（シートの列データ）並べ替え
Dim L As Long
Dim U As Long
Dim i As Long
Dim gap As Long
Dim Temp As Variant
Dim F As Boolean
L = LBound(Ary)
U = UBound(Ary)
gap = U - L
F = True
Do While gap > 1 Or F = True
gap = Int(gap / 1.3)
If gap = 9 Or gap = 10 Then
gap = 11
ElseIf gap < 1 Then
gap = 1
End If
F = False
For i = L To U - gap
If Ary(i, 1) > Ary(i + gap, 1) Then
Temp = Ary(i, 1)
Ary(i, 1) = Ary(i + gap, 1)
Ary(i + gap, 1) = Temp
F = True
End If
Next
Loop
Csort2 = Ary
End Function
Sub test()
Dim myList As Variant
Dim List2() As String
Dim c As Long
Dim i As Long
'元データ
myList = ActiveSheet.UsedRange.Columns(1).Value '※１列のデータでもセルから取得したものは２次元配列である
'昇順に並べ替え
myList = msQsort(myList)
c = 1
'入れ替え先の大きさはとりあえず適当
ReDim List2(1 To 10)
'１つめのデータ
List2(c) = myList(1, 1)
On Error GoTo RedimTrap
For i = 2 To UBound(myList)
'前のデータと違っていればユニークとして入れ替え先に追加する
If myList(i, 1) <> myList(i - 1, 1) Then
c = c + 1
List2(c) = myList(i, 1)
End If
Next
'入れ替え先の配列の、最終的な大きさを整える
ReDim Preserve List2(1 To c)
On Error GoTo 0
For i = 1 To UBound(List2)
Debug.Print List2(i)
Next
Exit Sub
'配列の拡張を効率的に行なうためのエラートラップ
RedimTrap:
If Err.Number = 9 Then
ReDim Preserve List2(1 To UBound(List2) * 2)
Resume
Else
Stop
End If
End Sub
Sub CallTest()
PutCharacter 100, 100, "100,100"
PutCharacter 100, 200, "100,200"
End Sub
Sub PutCharacter(Left As Single, Top As Single, Chara As String)
Dim myText As Shape
Set myText = ActiveSheet.Shapes.AddTextbox _
(msoTextOrientationHorizontal, Left, Top, 10, 10)
With myText
With .TextFrame.Characters
.Text = Chara
.Font.Name = "ＭＳ Ｐゴシック"
.Font.Size = 11
End With
.TextFrame.AutoSize = True
End With
Set myText = Nothing
End Sub
Sub WatchNewFile()
Const Pathh As String = "C:\Documents and Settings\user name\My Documents\"
Dim Fn As String
Dim myList As Variant
Static myList0 As Variant
Dim myList0_C As Long
Dim i As Long
Dim j As Long
Dim FF As Boolean
'現在のリスト取得
Fn = Dir(Pathh & "*.txt")
Do While Fn <> ""
i = i + 1
If i = 1 Then
ReDim myList(1 To 1)
Else
ReDim Preserve myList(1 To i)
End If
myList(i) = Fn
Fn = Dir()
Loop
On Error Resume Next
myList0_C = UBound(myList0)
On Error GoTo 0
'現在のリストのファイル名を
For i = 1 To UBound(myList)
FF = False
'前回のリスト中から検索し
For j = 1 To myList0_C
If myList0(j) = myList(i) Then
FF = True
Exit For
End If
Next
'無ければ（つまり新しいファイルなら）
If FF = False Then
'処理実行
Debug.Print myList(i)
End If
Next
'リスト保存
myList0 = myList
'次回起動指定
Application.OnTime Now() + TimeValue("00:00:05"), "WatchNewFile"
End Sub
===== ThisWorkbook =====
Option Explicit
Private WithEvents myExcel As Application
Private Sub myExcel_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
With Sh
MsgBox "BookName:" & .Parent.Name & vbCrLf & _
"SheetName:" & .Name & vbCrLf & _
"RangeAddress:" & Target.Address
End With
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myExcel = Nothing
End Sub
Private Sub Workbook_Open()
Set myExcel = Application
End Sub
Sub ReadCSV()
Dim myPath As String
Dim N As Integer
Dim D As String
Dim myVals As Variant
Dim rngDest As Range
Dim i As Integer
'読み込みファイル
myPath = ThisWorkbook.Path & "\test.csv"
N = FreeFile
'列数確認
Open myPath For Input As #N
Line Input #N, D
Close #N
myVals = Split(D, ",")
Application.ScreenUpdating = False
'書き込み先
Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
'全列共、書式を文字列に設定
rngDest.Resize(, UBound(myVals) + 1).EntireColumn.NumberFormat = "@"
Open myPath For Input As #N
'読み込み
Do Until EOF(N)
Line Input #N, D
myVals = Split(D, ",")
rngDest.Resize(, UBound(myVals) + 1).Value = myVals
Set rngDest = rngDest.Offset(1)
Loop
Close #N
Application.ScreenUpdating = True
End Sub
===== frmPassWord =====
Option Explicit
Public ClickedButton As Integer
Private Sub UserForm_Initialize()
ClickedButton = vbCancel
End Sub
Private Sub cmdOK_Click()
With Me.TextBox1
If .Value <> "abc" Then
MsgBox "NG", vbExclamation
.Value = ""
.SetFocus
Else
ClickedButton = vbOK
Me.Hide
End If
End With
End Sub
Private Sub cmdキャンセル_Click()
ClickedButton = vbCancel
Me.Hide
End Sub
===== 標準モジュール =====
Sub InputPassWord()
With frmPassWord
.Show
If .ClickedButton = vbOK Then
Unload frmPassWord
MsgBox "PassWord OK"
Else
Unload frmPassWord
MsgBox "Cancel"
End If
End With
End Sub
Sub SpinTest()
Dim myTable As Range
Dim mySpin As Shape
Dim L As Long
Dim U As Long
Dim i As Long
'表示データ
Set myTable = Worksheets("Sheet2").UsedRange.Columns(1)
L = 1
U = myTable.Rows.Count
Set mySpin = ActiveSheet.Shapes("スピン 1")
i = mySpin.ControlFormat.Value
'範囲を超えていたら戻して循環
If i < L Then
i = U
ElseIf i > U Then
i = L
End If
mySpin.ControlFormat.Value = i
'反転（ex. 2〜13 ---> 13〜2）
i = U - i + L
'値表示
Range("A1").Value = myTable.Cells(i, 1).Value
End Sub
Sub test()
Dim WSHShell As Object
Dim Ans As Integer
Set WSHShell = CreateObject("WScript.Shell")
Ans = WSHShell.Popup("３秒で終了します。取り消しますか？", 3, "終了取り消し", vbYesNo)
Set WSHShell = Nothing
If Ans = vbYes Then
MsgBox "終了を取り消しました。"
Else
MsgBox "終了します。"
End If
End Sub
Sub ReadCSV2()
'CSVファイルの任意の列を文字列として読み込む(改行コード任意の例)
Dim myPath As String
Dim N As Integer
Dim D As String
Dim Vin As Variant
Dim i As Long, j As Integer
Dim V As Variant
Dim Ary As Variant
Dim Vout() As String
Dim rngOut As Range
Const Cr As String = vbCrLf '改行コードは、vbLf, "!" など何でも良い
myPath = ThisWorkbook.Path & "\test.csv"
Ary = Array(1, 3, 5) '取出す列、１から数える
Set rngOut = Range("A2")
N = FreeFile
Open myPath For Input As #N
D = InputB(LOF(N), N)
Close #N
D = StrConv(D, vbUnicode)
'最後が改行コードならカットする
If Right$(D, Len(Cr)) = Cr Then
D = Left$(D, Len(D) - Len(Cr))
End If
Vin = Split(D, Cr)
ReDim Vout(1 To UBound(Vin) + 1, 1 To UBound(Ary) + 1)
For i = 1 To UBound(Vin) + 1
V = Split(CStr(Vin(i - 1)), ",")
For j = 1 To UBound(Ary) + 1
Vout(i, j) = V(Ary(j - 1) - 1)
Next
Next
With rngOut.Resize(UBound(Vout), UBound(Vout, 2))
.NumberFormat = "@"
.Value = Vout
End With
Erase Vin, Vout
End Sub
Sub ReadCSV()
Dim myPath As String
Dim N As Integer
Dim L As String
Dim A As Variant
Dim i As Integer
Dim rngDest As Range
myPath = ThisWorkbook.Path & "\test.csv"
N = FreeFile
Set rngDest = Workbooks.Add.Worksheets(1).Range("A1")
'列書式設定
With rngDest.Worksheet
.Columns("A:C").NumberFormat = "@"
.Columns(10).NumberFormat = "@"
End With
Open myPath For Input As #N
Do While Not EOF(N)
Line Input #N, L
A = Split(L, ",")
For i = 0 To UBound(A)
Select Case i +1
Case 3, 10
'削除
Case Else
rngDest.Offset(0, i).Value = A(i)
End Select
Next
Set rngDest = rngDest.Offset(1, 0)
Loop
Close #N
End Sub
===== ThisWorkbook =====
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim myCell As Range
Dim myRange As Range
With Target
'二列以上選択していたら
If .Columns.Count >= 2 Then Exit Sub
'B列以外だったら
If .Column <> 2 Then Exit Sub
'処理対象範囲をシートの使用範囲との交わり部分とする
Set myRange = Intersect(.Cells, Sh.UsedRange)
If myRange Is Nothing Then Exit Sub
If .Rows.Count = Sh.Rows.Count Then
'列クリックならリセット
For Each myCell In myRange
With myCell
If .Offset(0, -1).Value = "" Then
'左の列が空白なら
.Value = ""
End If
End With
Next
Else
'列クリックでなければ
For Each myCell In myRange
With myCell
If .Offset(0, -1).Value = "" Then
'左の列が空白なら
.Value = ""
Else
'そうでなければTrue False 切り替え
.Value = Not .Value
End If
End With
Next
End If
End With
Cancel = True
End Sub
===== UserForm1 =====
Private Sub cmd下へ_Click()
Dim myValue As Variant
Dim myIndex As Integer
With Me.lstFileNames
myIndex = .ListIndex
If myIndex = -1 Then Exit Sub
If myIndex = .ListCount - 1 Then Exit Sub
myValue = .List(myIndex)
.RemoveItem myIndex
.AddItem myValue, myIndex + 1
.ListIndex = myIndex + 1
End With
End Sub
Private Sub cmd上へ_Click()
Dim myValue As Variant
Dim myIndex As Integer
With Me.lstFileNames
myIndex = .ListIndex
If myIndex = -1 Then Exit Sub
If myIndex = 0 Then Exit Sub
myValue = .List(myIndex)
.RemoveItem myIndex
.AddItem myValue, myIndex - 1
.ListIndex = myIndex - 1
End With
End Sub
Private Sub UserForm_Initialize()
Dim myList As Variant
Dim L As Variant
myList = Array("a", "b", "c", "d", "e")
For Each L In myList
Me.lstFileNames.AddItem L
Next
End Sub
===== Sheet1 =====
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim L As Long
Dim T As Long
With ActiveWindow.ActivePane
L = Columns(.ScrollColumn).Left
T = Rows(.ScrollRow).Top
End With
With ActiveSheet.Shapes("図 1")
.Left = L
.Top = T
End With
End Sub
Sub myCheckBox()
Dim myShp As Shape
Set myShp = ActiveSheet.Shapes(Application.Caller)
With myShp.TopLeftCell.Offset(0, 2)
If .Value = False Then
.Value = True
myShp.Line.Visible = msoTrue
Else
.Value = False
myShp.Line.Visible = msoFalse
End If
End With
End Sub
Sub GetNewCSV()
Dim myPath As String
Dim myName As String
Dim tmpName As String
Dim myDate As Date
Dim tmpDate As Date
myPath = ThisWorkbook.Path & "\"
myName = Dir(myPath & "*.csv")
If myName = "" Then Exit Sub
myDate = FileDateTime(myPath & myName)
tmpName = Dir()
Do Until tmpName = ""
tmpDate = FileDateTime(myPath & tmpName)
If tmpDate > myDate Then
myName = tmpName
myDate = tmpDate
End If
tmpName = Dir()
Loop
MsgBox myPath & myName & vbLf & myDate
End Sub
Private Sub test()
Dim A As Variant
Dim Idx As Variant
Dim i As Integer
A = Array(6, 2, 4, 1, 7, 4, 9, 8, 4, 3, 7, 2, 5, 6, 4, 9, 1, 3, 2)
Idx = MsCombSortI(A)
For i = LBound(A) To UBound(A)
Debug.Print A(Idx(i));
Next
Debug.Print
End Sub
Private Function MsCombSortI(Ary As Variant) As Variant
'昇順インデックスを返す
'配列引数Aryは１次元限定
Dim Idx() As Long
Dim L As Long
Dim U As Long
Dim i As Long
Dim gap As Long
Dim Temp As Long
Dim F As Boolean
L = LBound(Ary)
U = UBound(Ary)
'インデックス初期設定
ReDim Idx(L To U)
For i = L To U
Idx(i) = i
Next
gap = U - L
F = True
'並べ替え
Do While gap > 1 Or F = True
gap = Int(gap / 1.3)
If gap = 9 Or gap = 10 Then
gap = 11
ElseIf gap < 1 Then
gap = 1
End If
F = False
For i = L To U - gap
If Ary(Idx(i)) > Ary(Idx(i + gap)) Then '降順時は <
Temp = Idx(i)
Idx(i) = Idx(i + gap)
Idx(i + gap) = Temp
F = True
ElseIf Ary(Idx(i)) = Ary(Idx(i + gap)) Then
If Idx(i) > Idx(i + gap) Then '昇順降順変更しても変更の必要なし
Temp = Idx(i)
Idx(i) = Idx(i + gap)
Idx(i + gap) = Temp
F = True
End If
End If
Next
Loop
MsCombSortI = Idx()
End Function
Private Sub セル範囲並べ替え()
Const 列 As Integer = 1
Dim A As Variant
Dim B As Variant
Dim C As Variant
Dim myRange As Range
Dim Idx As Variant
Dim L As Long
Dim U As Long
Dim L2 As Long
Dim U2 As Long
Dim i As Long
Dim j As Long
Set myRange = ActiveCell.CurrentRegion
A = myRange.Value
L = LBound(A)
U = UBound(A)
L2 = LBound(A, 2)
U2 = UBound(A, 2)
'２次元⇒１次元
ReDim B(L To U)
For i = L To U
B(i) = A(i, 列)
Next
'並べ替えインデックスを得る
Idx = MsCombSortI(B)
'配列内で並べ替え
ReDim C(L To U, L2 To U2)
For i = L To U
For j = L2 To U2
C(i, j) = A(Idx(i), j)
Next
Next
'セルに書き戻し
myRange.Value = C
Set myRange = Nothing
End Sub
Sub test()
Dim A As Variant
Dim i As Integer
A = Array(4, 2, 1, 7, 8, 4, 2, 5, 9)
A = Csort(A)
For i = LBound(A) To UBound(A)
Debug.Print A(i);
Next
Debug.Print
End Sub
Private Function Csort(ByVal Ary As Variant) As Variant
'昇順並べ替え、引数は１次元配列のみ可
Dim L As Long
Dim U As Long
Dim i As Long
Dim gap As Long
Dim Temp As Variant
Dim F As Boolean
L = LBound(Ary)
U = UBound(Ary)
gap = U - L
F = True
Do While gap > 1 Or F = True
gap = Int(gap / 1.3)
If gap = 9 Or gap = 10 Then
gap = 11
ElseIf gap < 1 Then
gap = 1
End If
F = False
For i = L To U - gap
If Ary(i) > Ary(i + gap) Then
Temp = Ary(i)
Ary(i) = Ary(i + gap)
Ary(i + gap) = Temp
F = True
End If
Next
Loop
Csort = Ary
End Function
Sub Isort()
Dim A As Variant
Dim i As Long
Dim j As Long
Dim Temp As Variant
A = Array(5, 3, 2, 7, 5, 6, 4, 2, 9, 7)
For i = LBound(A) + 1 To UBound(A)
Temp = A(i)
For j = i - 1 To LBound(A) Step -1
If A(j) > Temp Then
A(j + 1) = A(j)
Else
Exit For
End If
Next j
A(j + 1) = Temp
Next i
For i = LBound(A) To UBound(A)
Debug.Print A(i);
Next
Debug.Print
End Sub
Private Sub MsShell(Ary As Variant)
'シェルソート
'引数の値そのものを昇順に並べ替える、１次元配列のみ可
Dim L As Long
Dim U As Long
Dim N As Long
Dim i As Long
Dim j As Long
Dim Temp As Variant
Dim D() As Long
Dim DD As Long
Dim k As Long
L = LBound(Ary)
U = UBound(Ary)
N = U - L + 1
'比較間隔の配列準備
ReDim D(1 To 19) '19番目は約6億なのでこれで充分
D(1) = 1
i = 1
Do
Temp = D(i) * 3 + 1
If Temp < N Then
i = i + 1
D(i) = Temp
Else
Exit Do
End If
Loop
ReDim Preserve D(1 To i)
'並べ替え
For k = UBound(D) To 1 Step -1
DD = D(k)
For i = L To U - DD
j = i
Do While Ary(j) > Ary(j + DD)
Temp = Ary(j)
Ary(j) = Ary(j + DD)
Ary(j + DD) = Temp
j = j - DD
If j < L Then Exit Do
Loop
Next i
Next k
End Sub
Sub シート並べ替え()
'２シートめ以降を文字としてソート
Dim A() As String
Dim C As Integer
Dim i As Integer
C = Sheets.Count
ReDim A(2 To C)
For i = 2 To C
A(i) = Sheets(i).Name
Next
Bsort_LtoU A
For i = 2 To C
Sheets(A(i)).Move after:=Sheets(C)
Next
End Sub
Sub シート並べ替え2()
'並べ替え対象シートは２シートめ以降でシート名は数字限定
Dim A() As Long
Dim C As Integer
Dim i As Integer
C = Sheets.Count
ReDim A(2 To C)
For i = 2 To C
A(i) = Val(Sheets(i).Name)
Next
Bsort_LtoU A
For i = 2 To C
Sheets(CStr(A(i))).Move after:=Sheets(C)
Next
End Sub
Private Sub Bsort_LtoU(Ary As Variant)
'バブルソート
'引数の値そのものを昇順に並べ替える、１次元配列のみ可
Dim L As Long
Dim U As Long
Dim i As Long
Dim j As Long
Dim Temp As Variant
Dim F As Boolean
L = LBound(Ary)
U = UBound(Ary)
'並べ替え
For i = U To L + 1 Step -1
F = False
For j = L To i - 1
If Ary(j) > Ary(j + 1) Then
Temp = Ary(j)
Ary(j) = Ary(j + 1)
Ary(j + 1) = Temp
F = True
End If
Next
'交換が発生しなかったら（つまり並べ替わっていたら終わり）
If F = False Then Exit For
Next
End Sub
===== cChartクラス =====
Option Explicit
Private WithEvents myChart As Chart
Public Property Set Chart(Target As Chart)
Set myChart = Target
End Property
Public Property Get Chart() As Chart
Set Chart = myChart
End Property
Private Sub Class_Terminate()
Set myChart = Nothing
End Sub
Private Sub myChart_BeforeDoubleClick(ByVal ElementID As Long, ByVal Arg1 As Long, ByVal Arg2 As Long, Cancel As Boolean)
If ElementID = xlSeries Then
myExec myChart, Arg1, Arg2
End If
Cancel = True
End Sub
===== 標準モジュール =====
Option Explicit
Private myCharts() As cChart
Sub Sett()
Dim myChartOBJ As ChartObject
Dim C As Integer
Dim i As Integer
C = ActiveSheet.ChartObjects.Count
ReDim myCharts(1 To C)
For i = 1 To C
Set myCharts(i) = New cChart
Set myCharts(i).Chart = ActiveSheet.ChartObjects(i).Chart
Next
End Sub
Sub Resett()
Dim i As Integer
On Error Resume Next
For i = LBound(myCharts) To UBound(myCharts)
Set myCharts(i) = Nothing
Next
Erase myCharts
On Error GoTo 0
End Sub
Sub myExec(Target As Chart, SeriesIndex As Long, PointIndex As Long)
Dim myValues As Variant
With Target
MsgBox "グラフ名=" & .Name
MsgBox "グラフオブジェクト名=" & .Parent.Name
MsgBox "系列番号=" & SeriesIndex
MsgBox "ポイント番号=" & PointIndex
MsgBox "系列数式=" & .SeriesCollection(SeriesIndex).Formula
If PointIndex <> -1 Then
myValues = .SeriesCollection(SeriesIndex).XValues
MsgBox "X=" & myValues(PointIndex)
myValues = .SeriesCollection(SeriesIndex).Values
MsgBox "Y=" & myValues(PointIndex)
End If
End With
End Sub
Sub EraseShapes()
Dim myShp As Shape
Dim myRange As Range
Dim ShpRange As Range
Dim mySht As Worksheet
Set mySht = ActiveSheet
Set myRange = ActiveWindow.RangeSelection
For Each myShp In mySht.Shapes
With myShp
Set ShpRange = mySht.Range(.TopLeftCell, .BottomRightCell)
If Not Application.Intersect(ShpRange, myRange) Is Nothing Then
.Delete
End If
End With
Next
End Sub
Sub test()
Dim mySht As Excel.Worksheet
Dim myShp As Excel.Shape
Set mySht = ActiveSheet
For Each myShp In mySht.Shapes
If myShp.Type = msoFormControl Then
If myShp.FormControlType = xlCheckBox Then
With myShp.ControlFormat
'プロパティを書き出す
Debug.Print myShp.Name
Debug.Print .LinkedCell
Debug.Print .Value
Debug.Print mySht.Range(.LinkedCell).Value
End With
End If
End If
Next
End Sub
Sub Sett()
'リンクセルをチェックボックスの右のセルに設定する
Dim mySht As Excel.Worksheet
Dim myShp As Excel.Shape
Dim N As Integer
Set mySht = ActiveSheet
For Each myShp In mySht.Shapes
If myShp.Type = msoFormControl Then
If myShp.FormControlType = xlCheckBox Then
N = N + 1
myShp.TextFrame.Characters.Text = "チェック " & N
With myShp.ControlFormat
.LinkedCell = myShp.TopLeftCell.Offset(0, 1).Address
End With
End If
End If
Next
End Sub
===== ThisWorkbook =====
Option Explicit
Private WithEvents myExcel As Application
Private Sub Workbook_Open()
Set myExcel = Application
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myExcel = Nothing
End Sub
Private Sub myExcel_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
ウインドを並べて表示 Wn.Caption
End Sub
Private Sub ウインドを並べて表示(A As String)
Dim myWindows(1 To 5) As String
Dim W As Window
Dim B As String
Dim i As Integer
myWindows(1) = "A.xls"
myWindows(2) = "B.xls"
myWindows(3) = "C.xls"
myWindows(4) = "D.xls"
myWindows(5) = "E.xls"
'次のウインド名を求める
For i = 1 To UBound(myWindows)
If myWindows(i) = A Then
If i = UBound(myWindows) Then
B = myWindows(1)
Else
B = myWindows(i + 1)
End If
Exit For
End If
Next
If i > UBound(myWindows) Then Exit Sub
With myExcel
.EnableEvents = False
.ScreenUpdating = False
'全ウインド最小化
For Each W In .Windows
If W.Visible Then
W.WindowState = xlMinimized
End If
Next
'二つのウインドを元の大きさに戻す
.Windows(B).WindowState = xlNormal
.Windows(A).WindowState = xlNormal
'並べて表示
.Windows.Arrange ArrangeStyle:=xlVertical
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
===== ThisWorkbook =====
Option Explicit
Private WithEvents mySheet As Worksheet
Private Sub Workbook_Open()
Worksheets.Add
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Set mySheet = Sh
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set mySheet = Nothing
End Sub
Private Sub mySheet_Change(ByVal Target As Range)
MsgBox Target.Address
End Sub
===== ThisWorkbook =====
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Sh.Name <> "Sheet1" Then Exit Sub 'Sheet1でなければ
If Target.Columns.Count >= 2 Then Exit Sub '２列以上なら
If Target.Column <> 1 Then Exit Sub 'A列でなければ
If Target.Rows.Count = Sh.Rows.Count Then Exit Sub '列選択されたら
Cancel = True
Dim myCell As Range
For Each myCell In Target
With myCell
'偶数行なら
If .Row Mod 2 = 0 Then
If .Value = 1 Then
.Value = ""
.EntireRow.Interior.ColorIndex = xlNone
Else
.Value = 1
'ラベンダー
.EntireRow.Interior.Color = RGB(191, 127, 255)
End If
End If
End With
Next
End Sub
===== a.txt =====
aaaaa
bb
ccc
#1#
dddddd ←ここから
e
ff ←ここまでを抽出
#2#
gggg
hh
Sub Test()
Dim Fname As String
Dim N As Integer
Dim myData As String
Dim Mikke As Boolean
Fname = ThisWorkbook.Path & "\a.txt"
N = FreeFile(0)
Open Fname For Input As #N
Mikke = False
Do While Not EOF(N)
Line Input #N, myData
If myData = "#1#" Then
Mikke = True
Exit Do
End If
Loop
If Mikke = False Then
Close #N
Exit Sub
End If
Do While Not EOF(N)
Line Input #N, myData
If myData = "#2#" Then
Exit Do
Else
Debug.Print myData
End If
Loop
Close #N
End Sub
SampleData
Label xx yy
a 1 2
b 2 5
c 3 3
d 4 6
e 5 1
'ラベル、X、Yの順で並んだデータで散布図を描き各ポイントにラベルの値を表示する
Sub CreateChart()
Dim rngSource As Range
Dim myChartOBJ As ChartObject
Dim mySeries As Series
Dim myPoint As Point
Dim i As Integer
Dim Txt As String
'元データ範囲
Set rngSource = Range("A1:C6")
'元データ範囲の右にグラフ作成
With rngSource.Offset(, rngSource.Columns.Count)
Set myChartOBJ = ActiveSheet.ChartObjects.Add(.Left, .Top, 400, 300)
End With
With myChartOBJ.Chart
.ChartArea.AutoScaleFont = False
.ChartType = xlXYScatter
.SetSourceData rngSource.Offset(, 1).Resize(, 2), xlColumns
.ApplyDataLabels xlDataLabelsShowValue
.HasLegend = False
.ChartTitle.Text = "タイトル"
Set mySeries = .SeriesCollection(1)
i = 1
For Each myPoint In mySeries.Points
i = i + 1
'各ポイントのラベルに「値」を表示
Txt = rngSource.Cells(i, 1).Address(0, 0, xlR1C1, 0)
Txt = "=" & rngSource.Worksheet.Name & "!" & Txt
myPoint.DataLabel.Text = Txt
Next
End With
Set myPoint = Nothing
Set mySeries = Nothing
Set myChartOBJ = Nothing
Set rngSource = Nothing
End Sub
SampleData
xxx y1 y2 L1 L2
a 1 2 あ xx
b 3 3 い yy
c 5 4 う zz
Sub CreateChart()
Dim rngSource As Range
Dim myChartOBJ As ChartObject
Dim mySeries As Series
Dim myRange As Range
Dim SeriesCount As Integer
Dim myPoint As Point
Dim i As Integer
'元データ範囲
Set rngSource = Range("A1:C4")
'元データ範囲の右にグラフ作成
With rngSource.Offset(, rngSource.Columns.Count)
Set myChartOBJ = rngSource.Worksheet.ChartObjects.Add(.Left, .Top, 500, 300)
End With
With myChartOBJ.Chart
.ChartArea.AutoScaleFont = False
.ChartType = xlLineMarkers
.SetSourceData rngSource, xlColumns
.ApplyDataLabels xlDataLabelsShowValue
'表示するラベルのOffset
SeriesCount = .SeriesCollection.Count
For Each mySeries In .SeriesCollection
'ラベルの「値」のあるセル範囲
Set myRange = Range(Split(mySeries.Formula, ",")(2))
Set myRange = myRange.Offset(, SeriesCount)
i = 0
For Each myPoint In mySeries.Points
i = i + 1
'各ポイントのラベルに「値」を表示
myPoint.DataLabel.Text = myRange.Cells(i).Text
Next
Next
End With
Set myPoint = Nothing
Set myRange = Nothing
Set mySeries = Nothing
Set myChartOBJ = Nothing
Set rngSource = Nothing
End Sub
Sub データラベル表示()
Dim myChart As Chart
Dim mySeries As Series
Dim myPoint As Point
Dim i As Integer
Dim myVals As Variant
Const 基準値 As Integer = 10
Application.ScreenUpdating = False
Set myChart = ActiveChart
myChart.ApplyDataLabels xlDataLabelsShowNone
For Each mySeries In myChart.SeriesCollection
myVals = mySeries.Values
For i = 1 To UBound(myVals)
If myVals(i) > 基準値 Then
Set myPoint = mySeries.Points(i)
myPoint.ApplyDataLabels xlDataLabelsShowValue
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Sub Test()
Const Y As Single = 15
Dim myTop As Single
Dim myleft As Single
Dim myTxt As Shape
With ActiveChart.Axes(xlValue)
myTop = (Y - .MaximumScale) / (.MinimumScale - .MaximumScale)
End With
With ActiveChart.PlotArea
myTop = myTop * .InsideHeight + .InsideTop
myleft = .InsideLeft
End With
Set myTxt = ActiveChart.Shapes.AddTextbox _
(msoTextOrientationHorizontal, _
myleft, myTop, 10, 10)
With myTxt
.TextFrame.Characters.Text = CStr(Y)
.TextFrame.AutoSize = True
.Left = myleft
.Top = myTop - .Height
End With
End Sub
===== UserForm1 =====
Option Explicit
Private PosFpath As String
Private Sub cmdOK_Click()
Dim N As Integer
N = FreeFile
Open PosFpath For Output As #N
With Me
Print #N, .Left
Print #N, .Top
End With
Close #N
MsgBox "OK"
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim N As Integer
Dim D As Single
PosFpath = ThisWorkbook.Path & "\" & "FormPosition.txt"
If Dir(PosFpath) = "" Then Exit Sub
N = FreeFile
Open PosFpath For Input As #N
With Me
Input #N, D: .Left = D
Input #N, D: .Top = D
End With
Close #N
End Sub
===== frmA(frmB) =====
Option Explicit
Public ClickedButton As Integer
Private Sub cmd表示切替_Click()
ClickedButton = vbOK
Me.Hide
End Sub
Private Sub cmdキャンセル_Click()
ClickedButton = vbCancel
Me.Hide
End Sub
Private Sub UserForm_Initialize()
ClickedButton = vbCancel
End Sub
===== 標準モジュール =====
Sub test()
Do
frmA.Show
If frmA.ClickedButton = vbCancel Then
Unload frmA
Exit Do
End If
Unload frmA
frmB.Show
If frmB.ClickedButton = vbCancel Then
Unload frmB
Exit Do
End If
Unload frmB
Loop
End Sub
7月1日 7月2日 7月3日 7月4日 7月5日 7月6日
氏名 木 金 土 日 月 火
A ○ ○ ○
B ○ ○
C ○ ○
D ○ ○
E ○ ○ ○
F ○ ○
↓
月日 氏名
04/7/1 A
F
04/7/2 B
E
04/7/3 C
F
04/7/4 A
D
E
04/7/5 B
C
04/7/6 A
D
E
Sub 夜勤()
Dim myTable As Range
Dim myColumn As Range
Dim myDest As Range
Dim i As Integer
'処理対象範囲
Set myTable = ActiveSheet.UsedRange
'中の○の部分に絞る
With myTable
Set myTable = Intersect(.Offset(2, 1), .Cells)
End With
'書込み先
Set myDest = Worksheets.Add.Range("A1")
'項目名
myDest.Value = "月日"
myDest.Offset(0, 1).Value = "氏名"
Set myDest = myDest.Offset(1, 0)
'列（月日）のループ
For Each myColumn In myTable.Columns
'日付書込み
myDest.Value = myColumn.Cells(1).Offset(-2).Value
'書込み先を一列右へ
Set myDest = myDest.Offset(, 1)
'行（氏名）のループ
For i = 1 To myColumn.Cells.Count
With myColumn.Cells(i)
'○なら書込み
If .Value = "○" Then
'氏名書き込み
myDest.Value = myTable.Cells(i, 1).Offset(, -1).Value
'書込み先を一行下へ
Set myDest = myDest.Offset(1)
End If
End With
Next
'書込み先を一列左へ（日付の列）
Set myDest = myDest.Offset(, -1)
Next
Set myTable = Nothing
Set myColumn = Nothing
Set myDest = Nothing
End Sub
Public Sub 更新日確認()
Dim myIni As cMsIni
Dim iniPath As String
Dim iniSection As String
Dim iniKey As String
Dim 最終更新日 As String
Dim 現在の更新日 As String
'iniファイルで「最終更新日」を読み書きする準備
iniPath = ThisWorkbook.Path & "\myProject.ini"
iniSection = "[最終更新日]"
iniKey = "あるCSV="
Set myIni = GetMsIni
'最終更新日を取得
With myIni
.FilePath = iniPath
.Section = iniSection
最終更新日 = .GetData(iniKey)
End With
'現在のファイルの更新日を取得
現在の更新日 = FileDateTime(ThisWorkbook.Path & "\ある.csv")
'新しければ処理
If 現在の更新日 > 最終更新日 Then
MsgBox "処理"
'iniファイル上の最終更新日を書き換え
myIni.PutData iniKey, 現在の更新日
End If
'後始末
Set myIni = Nothing
'指定時間後に繰り返す
Application.OnTime Now() + TimeValue("00:00:10"), "更新日確認"
End Sub
Sub 色で並べ替え()
Dim mySort As MsToolsC.cMsQsort
Dim myRange As Range
Dim myRow As Range
Dim myLists() As Long
Dim myIndex As Variant
Dim i As Long
Dim tmpBook As Workbook
Dim tmpSheet As Worksheet
Dim tmpCell As Range
Const 対象列 As Integer = 1
'並べ替え準備
Set mySort = MsToolsC.GetMsQsort
'処理対象範囲
Set myRange = ActiveSheet.UsedRange
ReDim myLists(1 To myRange.Rows.Count)
'色の値を配列に読み込む
For i = 1 To myRange.Rows.Count
myLists(i) = myRange.Cells(i, 対象列).Interior.ColorIndex
Next
'配列を並べ替え、そのインデックスを得る
With mySort
.昇順 = True
.同値順位保持 = True
myIndex = .MsQsort(myLists)
End With
Application.ScreenUpdating = False
'作業用のブック準備
Set tmpBook = Workbooks.Add
Set tmpSheet = tmpBook.Worksheets(1)
Set tmpCell = tmpSheet.Range("A1")
'インデックス順に作業用のシートにコピー
For i = 1 To UBound(myIndex)
myRange.Rows(myIndex(i)).Copy tmpCell
Set tmpCell = tmpCell.Offset(1, 0)
Next
'作業用シートから書き戻し
tmpSheet.UsedRange.Copy myRange
Set tmpCell = Nothing
Set tmpSheet = Nothing
tmpBook.Close False
Set tmpBook = Nothing
Application.ScreenUpdating = True
End Sub
===== ThisWorkbook =====
Option Explicit
Private WithEvents myExcel As Application
Private Sub Workbook_Open()
Set myExcel = Application
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myExcel = Nothing
End Sub
Private Sub myExcel_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)
MsgBox Target.Address(1, 1, xlA1, 1)
Cancel = True
End Sub
===== ThisWorkbook =====
Option Explicit
Private rngBak As Range
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If rngBak Is Nothing Then
Else
rngBak.Interior.ColorIndex = xlNone
End If
Set rngBak = Union(Target.EntireRow, Target.EntireColumn)
rngBak.Interior.Color = vbYellow
End Sub
Option Explicit
Private myNumber As Integer
Private myStart As Single
Private NextTime As Date
Sub Start()
myStart = Timer
Hyouji
End Sub
Sub Hyouji()
If Timer - myStart < 60 Then
Range("A1").Value = myNumber
myNumber = (myNumber + 1) Mod 10
NextTime = Now + TimeValue("00:00:01")
Application.OnTime NextTime, "Hyouji"
End If
End Sub
Sub myEnd()
Application.OnTime NextTime, "Hyouji", , False
End Sub
Option Explicit
Private myTime As Date
Sub Startt()
myTime = Now() + TimeValue("00:00:10")
Application.OnTime myTime, "Startt"
'処理
MsgBox "次回：" & myTime
End Sub
Sub Stopp()
Application.OnTime myTime, "Startt", , False
End Sub
Option Explicit
Private rngTable As Range
Private DontMove As Boolean
Private Sub SpinButton1_Change()
If DontMove Then Exit Sub
Me.txt行番号 = Me.SpinButton1.Value
End Sub
Private Sub txt行番号_Change()
Dim R As String
R = Me.txt行番号
If R = "" Then
Me.txtあ.Value = ""
Me.txtい.Value = ""
Else
With Me.SpinButton1
If Val(R) >= .Min And Val(R) <= .Max Then
With rngTable.Item(Val(R))
'最左列の値
Me.txtあ.Value = .Offset(, 0).Value
'5列右の値
Me.txtい.Value = .Offset(, 5).Value
End With
DontMove = True
.Value = Val(R)
DontMove = False
End If
End With
End If
End Sub
Private Sub UserForm_Initialize()
'データ範囲(最左列)
Set rngTable = Worksheets("Sheet1").Range("A1")
Set rngTable = Range(rngTable, rngTable.End(xlDown))
With Me.SpinButton1
.Min = 1
.Max = rngTable.Rows.Count
.SmallChange = -1
.Orientation = fmOrientationVertical
End With
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
Const myMenu As String = "myMenu"
Dim Pop As CommandBarPopup
Cancel = True
With Application.CommandBars("Cell")
.Controls(1).BeginGroup = True
Set Pop = .Controls.Add(Type:=msoControlPopup, before:=1, temporary:=True)
With Pop
.Caption = myMenu
With .Controls.Add(Type:=msoControlButton)
.Caption = "Menu_1"
.OnAction = "Menu_1" '実行するプロシージャは標準モジュールに書く
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Menu_2"
.OnAction = "Menu_2" '実行するプロシージャは標準モジュールに書く
End With
End With
.ShowPopup
.Controls(myMenu).Delete
End With
End Sub
===== ThisWorkbook =====
Option Explicit
Private Sub Workbook_Open()
Dim newMenu As CommandBarButton
Dim i As Integer
For i = 5 To 1 Step -1
Set newMenu = Application.CommandBars("Cell") _
.Controls.Add(Type:=msoControlButton, _
before:=1, temporary:=True)
With newMenu
.Caption = "C" & i & "の値で埋める"
.OnAction = "Kakikomi"
.Parameter = i
End With
Next i
End Sub
===== 標準モジュール =====
Private Sub Kakikomi()
Dim CalledButton As CommandBarButton
Dim n As Integer
Set CalledButton = Application.CommandBars.ActionControl
n = CInt(CalledButton.Parameter)
'Cnの値で埋め尽くす
Selection.Value = Range("C" + CStr(n)).Value
End Sub
Dim xlApp
Dim xlBook
' Excelのインスタンス作成
Set xlApp = CreateObject("Excel.Application")
' Excelの表示有無
xlApp.Visible = False
' メッセージを表示しないように設定（これが無くてもマクロの警告は出ない）
xlApp.DisplayAlerts = False
' 指定したExcelブックを開く
Set xlBook = xlApp.Workbooks.Open("C:\Temp\Test.xls")
' Excelの標準モジュールのTestをCall
xlApp.Run "TEST"
'ブックを保存せずに閉じる
xlBook.Close False
' Excel終了
xlApp.Quit
' オブジェクトを解放
Set xlBook = Nothing
Set xlApp = Nothing
Sub 同じ行数ずつデータを転記()
Dim rngSource As Range
Dim myRows As Range
Dim rngDest As Range
Static myCell As Range
'転記の単位
Const myRowsCount As Integer = 6
'コピー元と転記先
Set rngSource = Worksheets("Sheet1").UsedRange
Set rngDest = Worksheets("Sheet2").Cells(1)
'基準セル（スタートはSheet1のActiveCellから）
If myCell Is Nothing Then
Worksheets("Sheet1").Activate
Set myCell = ActiveCell
Worksheets("Sheet2").Activate
End If
'基準セルから下ｎ行を取得
Set myRows = myCell.EntireRow
Set myRows = Application.Intersect(myRows, rngSource)
If myRows Is Nothing Then
MsgBox "End!"
Exit Sub
End If
Set myRows = myRows.Resize(myRowsCount)
'転記先のシートの値をクリアしてから値のみを貼り付ける
rngDest.Worksheet.Cells.ClearContents
myRows.Copy
rngDest.PasteSpecial xlPasteValues
'基準セルをｎ行下に移動する
Set myCell = myRows.Cells(myRows.Rows.Count, 1)
Set myCell = myCell.Offset(1, 0)
Set rngSource = Nothing
Set myRows = Nothing
Set rngDest = Nothing
End Sub
Sub 結合()
Dim SourceBook As Workbook
Dim rngSource As Range
Dim rngDest As Range
Dim myPath As String
Dim myFName As String
'処理対象のフォルダ指定
myPath = ThisWorkbook.Path & "\"
'新規ブックを作成し、そのSheet1のA1セルを書き込み先とする
Set rngDest = Application.Workbooks.Add.Worksheets(1).Cells(1, 1)
Application.ScreenUpdating = False
myFName = Dir(myPath & "*.xls")
Do Until myFName = ""
If myFName <> ThisWorkbook.Name Then
Set SourceBook = Application.Workbooks.Open(myPath & myFName)
Set rngSource = SourceBook.Worksheets(1).UsedRange
rngSource.Copy rngDest
Set rngDest = rngDest.Offset(rngSource.Rows.Count)
SourceBook.Close False
End If
myFName = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "ブックの結合が完了しました。", vbInformation
Set rngSource = Nothing
Set rngDest = Nothing
Set SourceBook = Nothing
End Sub
Sub myCSV()
Dim myColumn As Range
Dim myCell As Range
Dim myLastCell As Range
Dim myRow As Range
Dim Fname As String
Dim N As Integer
Dim i As Integer
Set myColumn = ActiveSheet.UsedRange
Set myColumn = myColumn.Columns(1)
Fname = ThisWorkbook.Path & "\Test.csv"
N = FreeFile(0)
Open Fname For Output As #N
For Each myCell In myColumn.Cells
With myCell
Set myLastCell = .EntireRow
Set myLastCell = myLastCell.Cells(myLastCell.Cells.Count)
Set myLastCell = myLastCell.End(xlToLeft)
If myLastCell.Column < myCell.Column Then
Set myRow = myCell
Else
Set myRow = .Worksheet.Range(myCell, myLastCell)
End If
End With
With myRow
Print #N, .Cells(1).Value;
For i = 2 To .Cells.Count
Print #N, ","; .Cells(i).Value;
Next
Print #N, ""
End With
Next
Close #N
Set myColumn = Nothing
Set myCell = Nothing
Set myLastCell = Nothing
Set myRow = Nothing
End Sub
Sub Sortt()
Dim myRange As Range
Dim myColumn As Range
Dim myCell As Range
Dim i As Long
Set myRange = ActiveCell.CurrentRegion
Set myColumn = myRange.Columns(1)
'「〃」を上の値と同じにする
For Each myCell In myColumn.Cells
With myCell
If .Value = "〃" Then
.Value = .Offset(-1).Value
End If
End With
Next
'並べ替え
myRange.Sort key1:=myColumn.Cells(1), Header:=xlYes
'元に戻す
For i = myColumn.Rows.Count To 2 Step -1
Set myCell = myColumn.Cells(i)
With myCell
If .Value = .Offset(-1).Value Then
.Value = "〃"
End If
End With
Next
Set myRange = Nothing
Set myColumn = Nothing
Set myCell = Nothing
End Sub
1 a 1
2 b a
3 c ⇒ 2
b
3
c
Sub Sample1()
Dim myRange As Range
Dim myRow As Range
Dim i As Integer
Set myRange = ActiveCell.CurrentRegion
For i = myRange.Rows.Count To 2 Step -1
Set myRow = myRange.Rows(i)
myRow.Insert shift:=xlDown
Next
Set myRange = myRange.Columns(2)
myRange.Copy
myRange.Offset(1, -1).PasteSpecial skipblanks:=True
myRange.Clear
Set myRange = Nothing
Set myRow = Nothing
End Sub
Sub test()
Dim myList As Range
Set myList = Selection
Set myList = Intersect(myList, myList.Offset(1))
myList.Select
End Sub
Sub Split97CallSample()
Const S As String = "aaa,b,cc,dddd"
Dim V As Variant
Dim i As Integer
V = Split97(S, ",")
For i = 0 To UBound(V)
Debug.Print V(i)
Next
End Sub
Public Function Split97(Exp As String, Deli As String) As Variant
'配列添え字の下限は0
Dim myArray() As String
Dim C As Integer
Dim i As Integer
Dim j As Integer
i = 1
Do
j = InStr(i, Exp, Deli)
If j = 0 Then
j = Len(Exp) + 1
End If
ReDim Preserve myArray(0 To C)
myArray(C) = Mid$(Exp, i, j - i)
i = j + Len(Deli)
C = C + 1
Loop While j <= Len(Exp)
Split97 = myArray
End Function
===== ThisWorkbook モジュール =====
Option Explicit
Private WithEvents myExcel As Application
'このブックのプロジェクト名と同じ値を設定すること
Private Const myProjectName As String = "myPrj"
Private Const BarCaption As String = "シート選択"
'機能を有効にするにはブックを開き直すかここを実行する
Private Sub Workbook_Open()
Set myExcel = Application
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myExcel = Nothing
End Sub
Private Sub myExcel_SheetBeforeRightClick _
(ByVal Sh As Object, ByVal Target As Range _
, Cancel As Boolean)
Dim myBar As CommandBarComboBox
Dim myBarName As String
Dim Wb As Workbook
Dim Ws As Worksheet
With Target
If .Columns.Count = Sh.Columns.Count Then
If .Rows.Count = Sh.Rows.Count Then
myBarName = "Cell"
Else
myBarName = "Row"
End If
ElseIf .Rows.Count = Sh.Rows.Count Then
myBarName = "Column"
Else
myBarName = "Cell"
End If
End With
Application.CommandBars(myBarName).Controls(1).BeginGroup = True
Set myBar = Application.CommandBars(myBarName).Controls.Add _
(Type:=msoControlComboBox, before:=1, temporary:=True)
With myBar
.Caption = BarCaption
.OnAction = myProjectName & ".ThisWorkbook.シート選択"
For Each Wb In Workbooks
For Each Ws In Wb.Worksheets
.AddItem Wb.Name & "!" & Ws.Name
Next
Next
End With
Application.CommandBars(myBarName).ShowPopup
myBar.Delete
Cancel = True
Set myBar = Nothing
End Sub
Private Sub シート選択()
Dim A As Variant
A = Split(Application.CommandBars.ActionControl.Text, "!")
Workbooks(A(0)).Worksheets(A(1)).Activate
End Sub
===== ThisWorkbook =====
Option Explicit
Private WithEvents myExcel As Application
'機能を有効にするにはブックを開き直すかここを実行する
Private Sub Workbook_Open()
Set myExcel = Application
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myExcel = Nothing
End Sub
Private Sub myExcel_SheetBeforeRightClick _
(ByVal Sh As Object, ByVal Target As Range _
, Cancel As Boolean)
Dim myBar As CommandBarPopup
Dim myBarName As String
With Target
If .Columns.Count = Sh.Columns.Count Then
If .Rows.Count = Sh.Rows.Count Then
myBarName = "Cell"
Else
myBarName = "Row"
End If
ElseIf .Rows.Count = Sh.Rows.Count Then
myBarName = "Column"
Else
myBarName = "Cell"
End If
End With
Application.CommandBars(myBarName).Controls(1).BeginGroup = True
Set myBar = Application.CommandBars(myBarName).Controls.Add _
(Type:=msoControlPopup, before:=1, temporary:=True)
With myBar
.Caption = "シート選択"
.OnAction = "myPrj.ThisWorkbook.シート選択表示"
End With
Application.CommandBars(myBarName).ShowPopup
myBar.Delete
Cancel = True
Set myBar = Nothing
End Sub
Private Sub シート選択表示()
Application.CommandBars("Workbook tabs").ShowPopup
End Sub
===== ThisWorkbook =====
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 1 Then Exit Sub
Application.CommandBars("Workbook tabs").ShowPopup
Cancel = True
End Sub
Private Sub Waitt(Optional T As Single = 1)
'T秒間待つ
Dim T1 As Single
T1 = Timer + T
Do While Timer < T1
DoEvents
Loop
End Sub
Sub test()
myFilter "BB", "M"
End Sub
Sub myFilter(項目 As String, 値 As String)
Dim rngDest As Range
Dim rngTitle As Range
Dim rngFind As Range
With ActiveCell.Worksheet.UsedRange
.Worksheet.AutoFilterMode = False
Set rngTitle = .Rows(1)
Set rngFind = rngTitle.Find(項目, , xlValues, xlPart)
If rngFind Is Nothing Then Exit Sub
.AutoFilter rngFind.Column, "=*" & 値 & "*"
Set rngDest = Worksheets.Add.Range("A1")
rngTitle.Copy rngDest
Set rngDest = rngDest.Offset(1)
With .Offset(1).SpecialCells(xlCellTypeVisible)
.Copy rngDest
.Delete xlUp
End With
.Worksheet.AutoFilterMode = False
End With
End Sub
Sub ショートカット作成()
'デスクトップにショートカットを作成する
'(Windows Script Host Object Modelに参照設定し、専用のオブジェクト型
'を使用すればインテリセンスが使用できる)
Dim Fld As String
Dim Wsh As Object 'IWshShell
Dim ShtCut As Object 'IWshShortcut_Class
Set Wsh = CreateObject("Wscript.Shell")
Fld = Wsh.SpecialFolders("Desktop")
Set ShtCut = Wsh.CreateShortcut(Fld & "\test.lnk")
With ShtCut
.TargetPath = ThisWorkbook.FullName
.WindowStyle = 1
.IconLocation = Application.Path & "\excel.exe, 1"
.Description = "ショートカット作成テスト"
.Save
End With
Set ShtCut = Nothing
Set Wsh = Nothing
End Sub
Sub test()
'デスクトップのパス
MsgBox CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Sub
Sub Call下付き()
下付き Selection
End Sub
Sub 下付き(Target As Range)
Dim A As String
Dim i As Integer
Dim myCell As Range
For Each myCell In Target.Cells
With myCell
For i = 1 To Len(.Value)
A = Mid$(.Value, i, 1)
If A Like "[-+0-9]" Then
.Characters(i, 1).Font.Subscript = True
End If
Next
End With
Next
End Sub
Public Function nCr(n As Integer, r As Integer, Optional RetMax As Boolean = False) As Variant
'組合せ nＣr の配列を返す、RetMax=TRueの時は組合せ数を返す
If n <= 0 Or r <= 0 Then Exit Function
If r > n Then Exit Function
Dim C() As Integer
Dim Rc As Long
Dim Max As Double
Dim i As Integer
Dim IJK() As Integer
Dim vntIJK As Variant
Dim Zan As Integer
Max = 1
For i = n To (n - r + 1) Step -1
Max = Max * i
Next
For i = r To 1 Step -1
Max = Max / i
Next
If RetMax = True Then
nCr = Max
Exit Function
End If
ReDim C(1 To Max, 1 To r)
Rc = 0
ReDim IJK(0 To 0)
Zan = r
IJK(0) = 0
vntIJK = IJK()
SetnCr C(), Rc, n, r, vntIJK, Zan - 1
nCr = C()
End Function
Private Sub SetnCr(C() As Integer, Rc As Long, n As Integer, r As Integer, ByVal vntIJK As Variant, ByVal Zan As Integer)
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim IJK() As Integer
If Zan = 0 Then
k = vntIJK(UBound(vntIJK))
For l = k + 1 To n
Rc = Rc + 1
For m = 1 To UBound(vntIJK)
C(Rc, m) = vntIJK(m)
Next
C(Rc, m) = l
Next
Else
ReDim IJK(0 To UBound(vntIJK) + 1)
For k = 0 To UBound(vntIJK)
IJK(k) = vntIJK(k)
Next
k = vntIJK(UBound(vntIJK))
For l = k + 1 To n - Zan
IJK(UBound(IJK)) = l
vntIJK = IJK()
SetnCr C(), Rc, n, r, vntIJK, Zan - 1
Next
End If
End Sub
Sub CallTest() '一行目(A1,B1,C1,...)に元データ、A2に組合せに使用するデータ数、A3以降に組合せを表示する例
Dim Source As Variant
Dim A As Variant
Dim R As Long, C As Integer
Dim i As Long, j As Integer
Dim B As Variant
With ActiveSheet
.UsedRange.Offset(2).Clear
Source = .Range(.Cells(1), .Cells(1).End(xlToRight)).Value
A = nCr(UBound(Source, 2), .Cells(2, 1).Value)
R = UBound(A, 1)
C = UBound(A, 2)
MsgBox R
Debug.Print R, C
If R > 65534 Then
MsgBox "多過ぎ！", vbExclamation
Exit Sub
End If
ReDim B(1 To R, 1 To C)
Application.ScreenUpdating = False
For i = 1 To R
For j = 1 To C
B(i, j) = Source(1, A(i, j))
'Debug.Print a(i, j),
Next ': Debug.Print
Next
.Cells(3, 1).Resize(R, C).Value = B
Application.ScreenUpdating = True
End With
End Sub
Public Function SignificantFigures(Number, L) As Double
'数値を有効数字L桁に四捨五入する
If Number = 0 Then
SignificantFigures = 0
Else
SignificantFigures = Application.Round(Number, -Int(Application.Log(Abs(Number))) - 1 + L)
End If
End Function