ExcelVBA 便利サンプルコード

自分用のメモなので、形は整ってないです。

日時データ(2010/1/1 12:00:00 等)から年月日時分秒の数値を取得

Sub GetDateTimeNumber()
'日時データ(2010/1/1 12:00:00  等)から年月日時分秒の数値を取得

    Dim lastRow As Long
    Dim dbl1 As Double
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    lastRow = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row   ' データのある最終行
    If lastRow < 3 Then
        Exit Sub
    End If
    
    For i = 3 To lastRow
        On Error GoTo ErrorHandler  'セルの値を小数に変換できなかった場合に対応
        If Cells(i, 2).Value <> "" Then  '日時データは2列目に入っているとする
            dbl1 = CDbl(Cells(i, 2).Value)   '日時データを小数値に変換
            Cells(i, 3) = Year(dbl1)  '年
            Cells(i, 4) = Month(dbl1)
            Cells(i, 5) = Day(dbl1)
            Cells(i, 6) = Hour(dbl1)
            Cells(i, 7) = Minute(dbl1)
            Cells(i, 8) = Second(dbl1)
        End If
ReturnPoint:
    Next i
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    Cells(2, 2).Select
    MsgBox "完了"
    
    Exit Sub
    
ErrorHandler:
    Resume ReturnPoint
    
End Sub

ファイル・フォルダのパス文字列をソートする。使う機会はありそう

Sub bbb()

  ' 1列目に、1行目からフルパスが入力されているとする

  Dim xRow As Long
  Dim str1 As String
  Dim yenPosition As Long
  Dim lastRow As Long
  
  lastRow = ActiveSheet.Cells(ActiveSheet.Rows.count, 1).End(xlUp).Row

  With ActiveSheet
    .Columns(1).Select
    Selection.Insert   ' ソートのために1列追加
    .Columns(1).NumberFormatLocal = "@"  ' セルの書式設定を文字列に
    
    xRow = 1
    Do While .Cells(xRow, 2) <> ""
      .Cells(xRow, 1) = .Cells(xRow, 2)
      str1 = .Cells(xRow, 1)
      
      yenPosition = InStrRev(str1, "\")  ' 文字列の後方から「\」を検索
      
      
      If InStr(Right(str1, Len(str1) - yenPosition), ".") <> 0 Then
      ' パスの最後の部分に "." が含まれる場合はファイルと判断する。パス文字列に "." が使えるので、完璧ではないが
      ' ファイル/フォルダの判別のための列を用意すれば完璧か
      
        str1 = Left(str1, yenPosition) & " " & Right(str1, Len(str1) - yenPosition)
        ' 最後にある「\」の後に、半角スペースを入れる。こうしないと、フォルダがファイルの後になってしまう
      End If
      
      .Cells(xRow, 1) = str1
      xRow = xRow + 1
    Loop
    
    .Range(Cells(1, 1), Cells(lastRow, 2)).Sort key1:=.Cells(1, 1)
    ' 加工したパス名を元にソートする
    .Columns(1).Delete
  
  End With

End Sub

1列目に入っている値をランダムソートする

' 1列目をランダムソートする
Sub aaa()

  Dim lngLastRow As Long
  Dim i As Long
  
  lngLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

  For i = 1 To lngLastRow
    ActiveSheet.Cells(i, 2) = Int((100000 - 1 + 1) * Rnd + 1)
    ' 2列目に、1～100000の整数をランダムに格納
  Next i
  
  ActiveSheet.Sort.SortFields.Clear
  ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(1, 2), Cells(1, 2)), SortOn:=xlSortOnValues, Order:=xlAscending
  
  With ActiveSheet.Sort
    .SetRange Range(Cells(1, 1), Cells(lngLastRow, 2))       ' データのある範囲
    .Header = xlNo                 ' 1行目をタイトル行とするか。今回はタイトル行と解釈しない
'    .Header = xlYes    こうすれば1行目をタイトル行と解釈する
    .Orientation = xlTopToBottom    ' 並べ替えの方向。xlTopToBottom で普通に上下方向に並べ替え
    .Apply    ' ソートを実行
  End With
  
  ActiveSheet.Range(Cells(1, 2), Cells(lngLastRow, 2)).Clear  ' ランダム数値をクリア
  
End Sub

独自のコレクション(Collection)を定義する

Dim col1 As New Collection   ' 独自定義のコレクション
Dim col2 As New Collection
Dim i As Long
Dim lngTotal As Long

'コレクションに要素を追加
col1.Add Worksheets("1")
col1.Add Worksheets("2")
col1.Add Worksheets("3")

For i = 1 To col1.Count  ' コレクションの要素数だけ走査
Debug.Print col1(i).Name  'コレクション内のシートオブジェクトのシート名を取得
Next i

'数値でも可能らしい
col2.Add 100
col2.Add 200
col2.Add 300

lngTotal = 0
For i = 1 To col2.Count
Debug.Print col2(i)
lngTotal = lngTotal + col2(i)
Next i

Debug.Print "合計:" & CStr(lngTotal)  ' 合計:600

MsgBox "AAA", vbYesNo + vbDefaultButton1 + vbInformation　のように、複数の整数型の引数を渡して、ビット演算で判定する例

Private Enum eStaffType
  eMale = 1   '2 ^ 0 * 1  男性
  eFemale = 2 '2 ^ 0 * 2  女性
  
  ePresident = 4  '2 ^ 2 * 1  社長
  eGeneralManager = 8 '2 ^ 2 * 2  部長
  eManager = 12     '2 ^ 2 * 3  課長
  eEmployee = 16    '2 ^ 2 * 4  社員
End Enum

Private Sub BitOperationSample()

  MsgBox "AAA", vbYesNo + vbDefaultButton1 + vbInformation
  'MsgBox関数は、複数の引数を+で加算して渡している。これの判定にはビット演算を使用している


  '列挙型の変数を宣言する
  Dim StaffType As eStaffType

  '変数StaffTypeにeFemale + eGeneralManagerを代入する
  StaffType = eFemale + eGeneralManager
  Debug.Print GetStaffType(StaffType)  '女性の部長
  
  StaffType = eMale + eEmployee
  Debug.Print GetStaffType(StaffType)  '該当なし
  
  StaffType = eMale + ePresident
  Debug.Print GetStaffType(StaffType)  '男性の社長
  
  
End Sub

Function GetStaffType(ByVal StaffType As Long) As String

  '変数StaffTypeの値がこの値かどうかをビット演算を使用して確認する
  '2の0乗がベースの値か、2の2乗がベースの値かを判定している
  
  Select Case True
    Case (StaffType And (eFemale + ePresident)) = (eFemale + ePresident)
      GetStaffType = "女性の社長"
    Case (StaffType And (eMale + ePresident)) = (eMale + ePresident)
      GetStaffType = "男性の社長"
    Case (StaffType And (eFemale + eGeneralManager)) _
      = (eFemale + eGeneralManager)
      GetStaffType = "女性の部長"
    Case Else
      GetStaffType = "該当なし"
  End Select
End Function

処理にかかった時間を計測する

Sub bbb()

  Dim i As Long
  Dim j As Long
  Dim startTime As Double
  Dim endTime As Double
  
  startTime = Timer    'Timerは、0：00：00からの経過時間を求める
  
  j = 0
  For i = 1 To 10000000
    j = j + 1
  Next i
  
  endTime = Timer
  
  Debug.Print endTime - startTime
End Sub

値の入っていないセルの範囲を全クリアする。書式設定だけがされているセルをクリアしたい時に使える

Sub DeleteNoValue_NoRange()
'値が入っていないが書式や罫線などの設定がある範囲、を削除する
'永久ループを避けるためにカウンタを用意したので、サーチする上限の回数は場合に応じて設定で
'上書き保存を繰り返すので、時間が相等にかかるのが欠点。200行くらいまでが現実的

  Dim lastRow As Long
  Dim lastColumn As Long
  Dim xRow As Long
  Dim xColumn As Long
  Dim boolDeleteRows As Boolean  '削除対象の行であるか
  Dim boolDeleteColumns As Boolean  '削除対象の列であるか
  Dim cautionCount As Long   '永久ループを避けるために、念のためカウンタを用意
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  cautionCount = 0
  boolDeleteRows = True
  boolDeleteColumns = True
  
  Rows.Hidden = False
  Columns.Hidden = False
  '非表示の行・列があると正しく判定されないので、全て表示する
  
  Do While (True)
    lastRow = Cells(1, 1).SpecialCells(xlCellTypeLastCell).row
    lastColumn = Cells(1, 1).SpecialCells(xlCellTypeLastCell).column
    
    If boolDeleteRows Then  ' 削除対象の行がまだある場合
      For xColumn = 1 To lastColumn
        If Cells(lastRow, xColumn).Value <> "" Then
        '値があるセルが1つでもある場合
          boolDeleteRows = False
          Exit For
        End If
      Next xColumn
    End If
    
    If boolDeleteRows Then
      Rows(lastRow).Delete  '行の削除
      ThisWorkbook.Save  '保存しないと、最終セルが更新されない
    End If
    
    If boolDeleteRows = False Then
    '削除対象の行がもう無い場合は、列の削除へ
      For xRow = 1 To lastRow
        If Cells(xRow, lastColumn).Value <> "" Then
        '値があるセルが1つでもある場合
          boolDeleteColumns = False
          Exit For
        End If
      Next xRow
    End If
    
    If boolDeleteRows = False And boolDeleteColumns Then
      Columns(lastColumn).Delete  '列の削除
      ThisWorkbook.Save
    End If

    If boolDeleteRows = False And boolDeleteColumns = False Then
    '削除対象の行も列も無い場合は、ループを抜ける
      Exit Do
    End If
    
    If cautionCount > 50000 Then
    'サーチ回数の上限はここで設定する
      MsgBox "サーチ回数の上限に達したので、処理を中断しました"
      Exit Do
    End If
    
    cautionCount = cautionCount + 1
    
  Loop
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "完了"

End Sub



Sub DeleteNoValue_SpecifiedRange()
'指定された列番号までの、値が入っていないが書式や罫線などの設定がある範囲、を削除する
'範囲指定を毎回しなければならないが、高速
  
  Dim inputVar As Variant
  Dim rangeColumn As Long  'サーチする最大列番号
  Dim lastRow As Long     '値のあるセルの最後の行番号
  Dim tempLastRow As Long
  Dim lastColumn As Long     '値のあるセルの最後の列番号
  Dim tempLastColumn As Long
  Dim xRow As Long
  Dim xColumn As Long
  
  
  inputVar = Application.InputBox("対象となる範囲の最終行番号(数値)を入力してください")
  If VarType(inputVar) = vbBoolean Then  ' Boolean型の場合は、キャンセルされた
    MsgBox "キャンセルされました"
    Exit Sub
  ElseIf inputVar = "" Then
    MsgBox "入力がありません。数値を入力してください"
    Exit Sub
  ElseIf IsNumeric(inputVar) = False Then
    MsgBox "数値ではありません。数値を入力してください"
    Exit Sub
  Else
    rangeColumn = CLng(inputVar)
  End If
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  If rangeColumn > ActiveSheet.Columns.Count Then
  '指定した数値が、シートの最大列数を超える場合
    rangeColumn = ActiveSheet.Columns.Count
  End If
  
  lastRow = 1
  lastColumn = 1
  
  For xColumn = 1 To rangeColumn
    tempLastRow = Cells(ActiveSheet.Rows.Count, xColumn).End(xlUp).row
    If lastRow < tempLastRow Then
      lastRow = tempLastRow
    End If
  Next xColumn
  
  For xRow = 1 To lastRow
    tempLastColumn = Cells(xRow, ActiveSheet.Columns.Count).End(xlToLeft).column
    If lastColumn < tempLastColumn Then
      lastColumn = tempLastColumn
    End If
  Next xRow

  Range(Cells(lastRow + 1, 1), Cells(ActiveSheet.Rows.Count, ActiveSheet.Columns.Count)).Clear
  '最終行の1つ下の行から、シートの最終行まで全クリア
  
  Range(Cells(1, lastColumn + 1), Cells(lastRow, ActiveSheet.Columns.Count)).Clear
  '最終列の1つ右の列から、シートの最終列までを全クリア
  
  ThisWorkbook.Save
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "完了"

End Sub


Sub DeleteNoValue_AllSearch()
'全ての列をサーチし、値が入っていないが書式や罫線などの設定がある範囲、を削除する
'「全ての列を対象」が最も高速。全列数が16000程度なので、全サーチしても時間はあまりかからない
'10000 行以上の行に書式が設定されていると､少し時間がかかる｡行数が増えるほど遅くなる
'列に関しては､最終列に書式が設定されていてもあまり速度に変化は無いようだ
  
  Dim lastRow As Long     '値のあるセルの最後の行番号
  Dim tempLastRow As Long
  Dim lastColumn As Long     '値のあるセルの最後の列番号
  Dim tempLastColumn As Long
  Dim xRow As Long
  Dim xColumn As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  lastRow = 1
  lastColumn = 1
  
  For xColumn = 1 To ActiveSheet.Columns.Count
    tempLastRow = Cells(ActiveSheet.Rows.Count, xColumn).End(xlUp).row
    If lastRow < tempLastRow Then
      lastRow = tempLastRow
    End If
  Next xColumn
  
  For xRow = 1 To lastRow
    tempLastColumn = Cells(xRow, ActiveSheet.Columns.Count).End(xlToLeft).column
    If lastColumn < tempLastColumn Then
      lastColumn = tempLastColumn
    End If
  Next xRow

  Range(Cells(lastRow + 1, 1), Cells(ActiveSheet.Rows.Count, ActiveSheet.Columns.Count)).Clear
  '最終行の1つ下の行から、シートの最終行まで全クリア
  
  Range(Cells(1, lastColumn + 1), Cells(lastRow, ActiveSheet.Columns.Count)).Clear
  '最終列の1つ右の列から、シートの最終列までを全クリア
  
  ThisWorkbook.Save
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "完了"

End Sub

A1形式のアドレスから列番号へ、列番号からA1形式の列のアドレスを求める

Function returnR1C1Column(column_val As Variant) As Long
'A1形式のアドレスから、列番号を返す。A～XFD以外の文字列を受け取った場合は、0を返す
'列のアルファベットは小文字でもOK

    On Error GoTo ErroHandler  'エラー発生時は、ErroHandlerへ
    
    Dim column_string As String
    
    column_string = CStr(column_val)  ' 文字列に変換できるかをチェック 変換できない場合は、ErroHandlerへ
    
    returnR1C1Column = Range(column_string).Column
    ' 列番号を求める。column_stringがアドレスにならないような文字列の場合はエラーになる
    
    On Error GoTo 0
    Exit Function
    
ErroHandler:
    returnR1C1Column = 0

End Function



Function returnA1Column(column_val As Variant) As String
'列番号から、A1形式の列文字列を返す。有効範囲外の数値の場合は、"0"を返す

    On Error GoTo ErroHandler  'エラー発生時は、ErroHandlerへ
    
    Dim column_long As Long
    Dim addressStr As String
    
    column_long = CLng(column_val)  ' Long型に変換できるかをチェック 変換できない場合は、ErroHandlerへ
    
    If column_long < 1 Or column_long > 16384 Then '範囲外の数値の場合
        returnA1Column = 0
        Exit Function
    End If
    
    addressStr = Cells(1, column_long).Address(0, 0)
    returnA1Column = Mid$(addressStr, 1, Len(addressStr) - 1)

    
    On Error GoTo 0
    Exit Function
    
ErroHandler:
    returnA1Column = "0"

End Function




＊＊＊＊＊＊＊＊　テスト用　　＊＊＊＊＊＊＊＊＊＊＊＊
    
Sub test_returnR1C1Column()  'returnR1C1Columnのテスト

    Dim range1 As Range
    Dim ws1 As Worksheet
    
    Set range1 = Range(Cells(1, 1), Cells(10, 1))
    Set ws1 = Worksheets(1)

    Range(Cells(1, 1), Cells(30000, 100)).Clear
    
    Cells(1, 1) = returnR1C1Column(range1)
    Cells(2, 1) = returnR1C1Column(ws1)
    Cells(3, 1) = returnR1C1Column(100)
    Cells(4, 1) = returnR1C1Column("A")
    Cells(5, 1) = returnR1C1Column("AAAA10")
    Cells(6, 1) = returnR1C1Column(10)
    Cells(7, 1) = returnR1C1Column("AB1")
    Cells(8, 1) = returnR1C1Column("aa1")

    Dim arrayAtoZ(25) As String
    Dim addressStr As String
    Dim rowCount As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long

    arrayAtoZ(0) = "A"
    arrayAtoZ(1) = "B"
    arrayAtoZ(2) = "C"
    arrayAtoZ(3) = "D"
    arrayAtoZ(4) = "E"
    arrayAtoZ(5) = "F"
    arrayAtoZ(6) = "G"
    arrayAtoZ(7) = "H"
    arrayAtoZ(8) = "I"
    arrayAtoZ(9) = "J"
    arrayAtoZ(10) = "K"
    arrayAtoZ(11) = "L"
    arrayAtoZ(12) = "M"
    arrayAtoZ(13) = "N"
    arrayAtoZ(14) = "O"
    arrayAtoZ(15) = "P"
    arrayAtoZ(16) = "Q"
    arrayAtoZ(17) = "R"
    arrayAtoZ(18) = "S"
    arrayAtoZ(19) = "T"
    arrayAtoZ(20) = "U"
    arrayAtoZ(21) = "V"
    arrayAtoZ(22) = "W"
    arrayAtoZ(23) = "X"
    arrayAtoZ(24) = "Y"
    arrayAtoZ(25) = "Z"
    
    rowCount = 2
    
    For i = 0 To 25
        addressStr = arrayAtoZ(i) & "1"
        Cells(rowCount, 3) = addressStr
        Cells(rowCount, 4) = returnR1C1Column(addressStr)
        rowCount = rowCount + 1
    Next i
    
    
    rowCount = 2
    For i = 0 To 25
        For j = 0 To 25
            addressStr = arrayAtoZ(i) & arrayAtoZ(j) & "2"
            Cells(rowCount, 7) = addressStr
            Cells(rowCount, 8) = returnR1C1Column(addressStr)
            rowCount = rowCount + 1
        Next j
    Next i
    
    
    
    rowCount = 2
    For i = 0 To 25
        For j = 0 To 25
            For k = 0 To 25
                addressStr = arrayAtoZ(i) & arrayAtoZ(j) & arrayAtoZ(k) & "3"
                Cells(rowCount, 11) = addressStr
                Cells(rowCount, 12) = returnR1C1Column(addressStr)
                rowCount = rowCount + 1
            Next k
        Next j
    Next i

End Sub




Sub test_returnA1Column()  'returnA1Columnのテスト

    Dim range1 As Range
    Dim ws1 As Worksheet
    
    Set range1 = Range(Cells(1, 1), Cells(10, 1))
    Set ws1 = Worksheets(1)

    Range(Cells(1, 1), Cells(30000, 2)).Clear
    
    Cells(1, 1) = returnA1Column(range1)
    Cells(2, 1) = returnA1Column(ws1)
    Cells(3, 1) = returnA1Column("AA")
    Cells(4, 1) = returnA1Column("10")
    Cells(5, 1) = returnA1Column(12.35)
    Cells(6, 1) = returnA1Column(-5)
    Cells(7, 1) = returnA1Column(0)
    Cells(8, 1) = returnA1Column(16385)
    Cells(9, 1) = returnA1Column(3)
    Cells(10, 1) = returnA1Column("A1")


    ' 以下は、test_returnR1C1Column()で全てのA1形式のアドレスをC列に入力してある前提
    Dim i As Long
    
    For i = 2 To 16385
        Cells(i, 4) = returnA1Column(i - 1)
    Next i

End Sub

文字列の中の数値部分のみを、通貨形式の表示にする

***********   文字列の中の数値部分のみを、通貨形式の表示にする    ***********

Sub aaa()

    Dim cellValue As String
    
    Range("A1").Value = "お値段は100000円(税込み)"
    
    cellValue = ChangeNumberFormat(Range("A1").Value)  ' 数値を通貨形式に変更する処理を呼び出し
    MsgBox cellValue
    Range("A1").Value = cellValue
    
    
    Range("A2").Value = "日本では252000円(税込み)、アメリカでは2236ドル"
    ' 数値部分が複数あってもOK
    
    cellValue = ChangeNumberFormat(Range("A2").Value)
    MsgBox cellValue
    Range("A2").Value = cellValue
    
End Sub


Function ChangeNumberFormat(valueString As String) As String
' 文字列の数値部分の書式を通貨形式に変換した値を返す

    Dim xReg As Variant              ' 正規表現オブジェクト
    Dim xMatch As Variant            ' パターンにマッチした部分
    Dim matchCollection As Variant   ' パターンにマッチした部分のコレクション
    
    Set xReg = CreateObject("VBScript.RegExp")   ' 正規表現オブジェクト作成
    
    With xReg
        .Pattern = "\d+"
        ' 「\d」は数値、「+」は直前のパターンの1回以上の繰り返し。"\d+"は「1文字以上の数字」というパターンになる
        .Global = True
        
        Set matchCollection = .Execute(valueString)  ' 検索実行し、マッチした部分を全てmatchCollectionに格納
        If matchCollection.Count > 0 Then  ' マッチする部分があった場合
        
            For Each xMatch In matchCollection
                valueString = Replace(valueString, xMatch, Format(xMatch, "#,###"))
                ' マッチした部分を通貨形式のフォーマットに置き換える
            Next xMatch
            
        End If
        
    End With
    
    Set xReg = Nothing
    
    ChangeNumberFormat = valueString

End Function

文字列と文字列の間にタブを挟んで、横位置を揃える

Dim message As String

Cells(1, 1).Value = "1200"
Cells(2, 1).Value = "985600"
Cells(3, 1).Value = "6812000"
Cells(4, 1).Value = "250"
Cells(1, 2).Value = "高橋"
Cells(2, 2).Value = "鈴木"
Cells(3, 2).Value = "遠藤"
Cells(4, 2).Value = "大沢"

message = message & Cells(1, 1).Value & " " & Cells(1, 2).Value & vbCrLf
message = message & Cells(2, 1).Value & " " & Cells(2, 2).Value & vbCrLf
message = message & Cells(3, 1).Value & " " & Cells(3, 2).Value & vbCrLf
message = message & Cells(4, 1).Value & " " & Cells(4, 2).Value

MsgBox message
' A列の値とB列の値の間に半角スペースを置いて表示したが、A列の値の文字数がバラバラで見にくい

message = ""
message = message & Cells(1, 1).Value & Chr(9) & Cells(1, 2).Value & vbCrLf
message = message & Cells(2, 1).Value & Chr(9) & Cells(2, 2).Value & vbCrLf
message = message & Cells(3, 1).Value & Chr(9) & Cells(3, 2).Value & vbCrLf
message = message & Cells(4, 1).Value & Chr(9) & Cells(4, 2).Value

MsgBox message
' A列の値とB列の値の間にタブ( Chr(9) )を入れると、B列の値の部分が横位置揃いになるので見やすくなる

重複するデータが無い、データのコレクションを作る　Scripting.Dictionary オブジェクト利用

Dim dic As Variant   ' Dictionaryオブジェクトとして使用
Dim keys As Variant
Dim i As Long

Set dic = CreateObject("Scripting.Dictionary")
' Scripting.Dictionary は本来キーと値の組み合わせを登録して使うもの(JavaのMapみたい？)らしい

For i = 1 To 10
    dic.Add i, "ABC"   ' キーと値の組み合わせで登録。今回は値の内容は無関係
Next i
' これでdicのキーに、1～10の数値が登録される
' キーは同じ値を登録できない。(1,"ABC")と(1,"XYZ")を一緒に登録は不可

If dic.Exists(10) Then
' dicのキーに10が存在する場合、という判定になる
    MsgBox "10はすでに登録済みのキー値です"
End If

If dic.Exists(20) Then
    MsgBox "20はすでに登録済みのキー値です"
Else
    dic.Add 20, "ABC"   ' 20はまだキーとして登録していないので、登録
End If


dic.Add "KKK", "ABC"   ' キーの値は文字列型でもOK


MsgBox "データ数は： " & dic.count   ' データの数を取得

keys = dic.keys  ' dicのキーのコレクションを取得
For i = 0 To dic.count - 1   ' インデックス番号は0から始まる
    Debug.Print keys(i)
    ' 全てのキーの値を表示
Next i

Set dic = Nothing

Cells(1, 1).Value = "AAA"
Cells(2, 1).Value = "BBB"
Cells(3, 1).Value = "CCC"
Cells(4, 1).Value = "AAA"
Cells(5, 1).Value = "CCC"
Cells(6, 1).Value = "EEE"
Cells(7, 1).Value = "DDD"
Cells(8, 1).Value = "EEE"
Cells(9, 1).Value = "FFF"
Cells(10, 1).Value = "GGG"
' A列に、10個のデータをセット。重複しているものあり

Set dic = CreateObject("Scripting.Dictionary")

For i = 1 To 10
    If Not dic.Exists(Cells(i, 1).Value) Then   ' Cells(i, 1)のデータが、dicのキー値として登録されていない場合
        dic.Add Cells(i, 1).Value, "適当な値"
        ' キー値として登録
    End If
Next i
' これで重複なしでA列のデータを登録できた


Cells(1, 2).Value = "A列のデータから重複を取り除いたもの"  ' B列のタイトル

keys = dic.keys
For i = 0 To dic.count - 1
    Cells(i + 2, 2).Value = keys(i)
Next i
' B列にdicのキー値を入力。A列の重複データを取り除いたものが完成

CountIf関数を使って、指定セル範囲内に重複があるかどうかを調べる　　処理も速くていい

Dim i As Long
  
For i = 1 To 100
  If WorksheetFunction.CountIf(Range("A1:A100"), Cells(i, 1)) > 1 Then
  '同じ値が2つ以上ある場合は、重複していると判断できる
    Cells(i, 1).Font.ColorIndex = 3
  End If
Next i