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 '素数配列(添え字1から)の取得 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は1次元限定 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 '昇順並べ替え、引数は1次元配列のみ可。 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 '指定セルから最終行(そのシートの最終使用行)までの「1列」を返す 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以上 ※とりあえず、コマンドボタン・チェックボックス・オプションボタンのクリック、テキストボックスのチェンジの4イベントのみ ^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}" '同じ半角英字が3文字続いていたら Bf = "AB" '全角 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() 'テキストファイル中の特定文字列数をカウントする、その2(正規表現を使用せず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クラスの機能 '1.テキストファイルの改行コードを含む一括読み込み '2.テキストファイルを行毎に分割して配列に読み込み '3.改行コードを任意に指定可能 '4.上書きモードまたは追加モードでテキストファイルへ書き込み '5.書き込み時、最後に改行コードを付けるか付けないかを選択可 '6.シフトJISに加えて、Unicodeテキストも自動認識 '7.デスクトップパスとマイドキュメントパス取得のおまけ付き '8.二次元配列から指定の一列を取得する関数(メソッド)のおまけ付き ' '●プロパティとメソッド '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列の二次元配列での取得も可能です。これはその値をそのままワークシート上に縦に貼り付ける時に便利な機能です。なお、配列以外を引数として渡しても、要素が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 '書き込み位置は最後+1バイト目 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 = "テスト3" ' ' 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("テスト4") 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は0から 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
'2次元配列の後方カット 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) '昇順並べ替え、引数は1次元配列のみ可 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は1次元限定 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として作る。 'サブフォルダがあるフォルダを選んだ時 ' 各々のサブフォルダ内のファイルへのショートカットを、選んだフォルダ内に作る 'サブフォルダが無いフォルダを選んだ時 ' 選んだフォルダ内のファイルへのショートカットを、親フォルダ内に作る '※つまり、一括で実行したい時はサブフォルダの親フォルダを選択し、個別に実行したい時はサブフォルダ1個を選択すれば良い 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
'使い方 '1.初期ページをIEで表示し、URLをコピーしておく '2.SavePictures()を実行 '3.StartURLに上記URLをペースト '4.EndNumberに最終番号入力 '5.「続けますか?」に対して「OK」クリック '6.保存ダイアログで場所を指定して保存(場所の指定は一回目のみ) '7.5に戻るので、必要なだけ繰り返す、途中でやめるときは「キャンセル」クリック 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 'とりあえず5つ、全部なら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
※使用方法: 0.シート上のボタンなどでFlgのONOFFを切り替える。 1.ONの状態の時、右クリックすると選択範囲がコピーされる。 2.そのコピー状態の時、別の場所を右クリックすると、コピーされている(破線範囲)と右クリックした範囲の値が交換される。 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 '指定シートの特定列の8桁文字列を日付に変換する 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 '指定セル範囲の8桁文字列を日付に変え、書式は「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() '範囲を指定した整数を羅列した、4列のテキストファイルを作る。 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 '使用範囲の1列目に対して連番(こちらの方が実用的か?) 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
'※重要な注意:掲示板によっては頭のインデント以外の部分も半角空白が1つに縮められる場合があるので、そこは良く確認してください。 'クリップボード内の半角スペースインデントを全角スペースに置き換える '(Microsoft Forms x.x Object Libraryへの参照設定が必要) Sub ConvCode() Const Before As String = " " 'ここは半角空白4つ 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 & "1234" & 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 '画像行数3行毎に改ページを挿入する 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 '出力先シート '何階層めまで対象とするか(指定フォルダを1階層めとする。設定は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() '範囲を指定した整数を羅列した、4列のテキストファイルを作る。 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の範囲の重複の無い乱配列を返す。添え字は1から。 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文字+数字2桁+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」だとして、 1.ThisWorkbookモジュールに次のプログラムをコピペします。 2.そして、非表示()をダイレクトに実行してシートを隠します。 3.プロジェクトの保護をします。(もちろんパスワード付きで) 4.ブックを保存します。 これで、ブックを開く時にマクロを有効にしないとシートが表示されません。 そして、マクロが有効になっていれば印刷はキャンセルされます。 (ただし、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 '1箇所に2つ以上データがある場合は並べ替える(ただし文字としての並べ替え) 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
固定長テキストファイル ID 名称 色 大きさ 重さ 0001 みかん オレンジ 8cm 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 '2バイト文字を2バイト、1バイト文字を1バイトとして扱う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
1 2 1 2 3 2 2 4 4 3 5 6 ⇒ 4 4 7 7 5 8 9 6 9 11 7 7 10 12 8 9 9 10 11 12 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 '1ファイルめの1行目のみタイトルとして出力 If Lc = 1 Then If Fc = 1 Then Print #Nout, D End If Else '2行目以降はすべて出力 Print #Nout, D End If Loop Close #Nin Fname = Dir() Loop Close #Nout End Sub
B E A A C G B D A ⇒ C C F C D A E F G 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 '要変更箇所1:プロジェクト名 Private Const MenuCaption As String = "Menu-1" '要変更箇所2:メニュー名 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) '要変更箇所3 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() '要変更箇所4 MsgBox "I am SubMenuA" End Sub Private Sub SubMenuB() '要変更箇所4 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 a 1 2 b 2 5 c 3 3 d 4 6 e 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 A B C D E F 1 スタート あ い う え お 2 あ あ う お 3 う あ い う え 4 お い お 5 エンド 6 スタート 7 あ 8 え 9 い 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 '1列のみの2次元配列(シートの列データ)並べ替え 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 '※1列のデータでもセルから取得したものは2次元配列である '昇順に並べ替え myList = msQsort(myList) c = 1 '入れ替え先の大きさはとりあえず適当 ReDim List2(1 To 10) '1つめのデータ 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 = "MS Pゴシック" .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秒で終了します。取り消しますか?", 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) '取出す列、1から数える 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は1次元限定 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) '2次元⇒1次元 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 '昇順並べ替え、引数は1次元配列のみ可 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) 'シェルソート '引数の値そのものを昇順に並べ替える、1次元配列のみ可 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 シート並べ替え() '2シートめ以降を文字としてソート 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() '並べ替え対象シートは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) 'バブルソート '引数の値そのものを昇順に並べ替える、1次元配列のみ可 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 '2列以上なら 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 '基準セルから下n行を取得 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 '基準セルをn行下に移動する 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 '組合せ nCr の配列を返す、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