Name ファイルパス As 変更後ファイルパス '勿論エラー処理が必要
指定の文字が何個含まれるか数える
Private Function stringCount(strA As String, strB As String) As Integer stringCount = UBound(Split(strA, strB)) End Function 'エラー処理が必要
ハイパーリンクを削除して保存を繰り返す
Sub ハイパーリンクを削除して保存する処理() Dim targetWb As Workbook, targetWsh As Worksheet Dim strFolderPath As String strFolderPath = ThisWorkbook.Path & "\指定フォルダ\" '画面の更新を停止して処理を高速化 Application.ScreenUpdating = False do '複数ファイルを対象とするループ条件をここに記載 Set targetWb = Workbooks.Open("ファイルパス") Set targetWsh = targetWb.Sheets(1)'対象シート指定 With targetWsh If .Hyperlinks.Count > 0 Then .Hyperlinks.Delete 'ハイパーリンクの削除 End If End With 'ファイルの保存と終了 If targetWb.Saved = False Then targetWb.Save targetWb.Close Set targetWsh = Nothing Set targetWb = Nothing Loop Application.ScreenUpdating = True Application.StatusBar = False 'Excelに返す End Sub '上記のままでは正しく動きません。無限ループになったら[Esc]で抜けましょう。
フォーム上でログ表示したい
'formにListBoxを用意して、Moduleに以下を追加 Private Sub LogAdd(s As String) If s = "" Then Exit Sub With UserForm1.LstBox_Log .AddItem s .ListIndex = .ListCount - 1 '最後尾を選択 .Selected(.ListCount - 1) = False '選択解除 End With DoEvents End Sub '使い方 Call LogAdd("処理を開始しました") 'フォーム上でのログクリア例 Me.LstBox_Log.Clear
オートフィルタで重複データを抽出
Sub Macro1() ' 重複データに色をつける条件付き書式 Range("B:B").Select Range("B:B").FormatConditions.Delete Selection.FormatConditions.AddUniqueValues '条件付き書式の追加 Selection.FormatConditions(1).DupeUnique = xlDuplicate '重複 Selection.FormatConditions(1).Interior.Color = RGB(255, 199, 206) 'ピンク背景 Range("A1").Select End Sub Sub Macro2() ' オートフィルタで色つきセルを抽出 Range("A1").AutoFilter _ Field:=2, Criteria1:=RGB(255, 199, 206), Operator:=xlFilterCellColor End Sub Sub Macro3() ' 条件付き書式を削除する Range("B:B").FormatConditions.Delete End Sub Sub Macro4() 'フィルタの条件クリア If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End Sub
カレントディレクトリの変更とファイル選択ダイアログの表示場所
Private Sub readLineTextFile() Dim fType As String, promptText As String, chDirPath As String Dim fPath As Variant Dim buf As String 'カレントディレクトリを移動 curDirPath = CurDir ChDir ActiveWorkbook.Path fType = "テキストファイル (*.txt),*.txt" promptText = "テキストファイルを選択して下さい" fPath = Application.GetOpenFilename(fType, , promptText) 'ファイル選択ダイアログ表示 ChDir curDirPath '元に戻す 'ダイアログでキャンセルボタン選択時は処理を終了 If fPath = False Then End On Error GoTo err_rtn Open fPath For Input As #1 Do Until EOF(1) Line Input #1, buf '1行ずつ読み込んで何かしらの処理 Loop err_rtn: Close #1 End Sub
Dictionaryと自作クラスで配列
'クラスモジュールKakunouClassを作成 Public Name As String Public Father As String Public Mother As String '自分自身を返す Public Property Get Self() As KakunouClass Set Self = Me End Property
'標準モジュール等 Dim kakunou_dic, buf As String Dim kc As KakunouClass '自作のデータ格納クラス Set kakunou_dic = CreateObject("Scripting.Dictionary") buf = "テスト" If Not Kakunou_dic.Exists(buf) Then With New KakunouClass .Name = buf .Father = "父" kakunou_dic.Add buf, .Self End With End If '配列からクラスを取得(削除)して追加 If kakunou_dic.Exists(buf) Then Set kc = kakunou_dic.Item(buf) 'Debug.Print "kc.Father = " & kc.Father '確認 kc.Mother = "母" kakunou_dic.Remove buf Kakunou_dic.Add buf, kc End If
以上。