つらつら Excel VBA

私の備忘録です。

ハイパーリンクを削除して保存を繰り返す

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

以上。