Home Excel(エクセル)マクロ・VBA

企業研修講師派遣のBESTグループ
出張パソコン教室ITスクール
webコンサルティングスクール
パソコンの家庭教師BEST

初期状態では「開発」リボンは表示されていません。
マクロの自動記録やフォームコントロールを使いたい時など困ってしまいます。
Officeボタン→[Excelのオプション]を実行します。

[基本設定]で「[開発]タブをリボンに表示する」にチェックを入れます。

[開発]タブが表示されました。
 

Dictionaryを利用する

Dictionaryオブジェクトを利用します。
このページの中ではもっとも短時間で処理できます。
コード例
Sub myDic()
  Dim myDic As Object, myKey As Variant
  Dim c As Variant, varData As Variant
    Set myDic = CreateObject(“Scripting.Dictionary”)
    With Worksheets(“Sheet1″)
      varData = .Range(“A1″, .Range(“A” & Rows.Count).End(xlUp)).Value
    End With
    For Each c In varData
      If Not c = Empty Then
        If Not myDic.Exists(c) Then
          myDic.Add c, Null
        End If
      End If
    Next
    myKey = myDic.Keys
    With Worksheets(“Sheet2″)
      .Range(“G:G”).ClearContents
      .Range(“G1″).Resize(myDic.Count) = Application.WorksheetFunction.Transpose(myKey)
    End With
    Set myDic = Nothing
End Sub
 

フィルタオプションの設定を利用する

Excelの一般機能であるフィルタオプションの設定を利用します。
フィルタオプションの設定では列見出しが必要ですので、仮の見出しを挿入して抽出後に削除しています。
配列の方法より短時間で処理できます。
コード例
Sub myAd()
  Dim rngData As Range, rngC As Range
  With Worksheets(“Sheet1″)
    .Range(“A1″).Insert xlDown
    .Range(“A1″).Value = “見出し”
    Set rngData = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
    Set rngC = Worksheets(“Sheet2″).Range(“E1″)
    rngData.AdvancedFilter _
      Action:=xlFilterCopy, _
      CopyToRange:=rngC, _
      Unique:=True
    .Range(“A1″).Delete xlUp
  End With
  With Worksheets(“Sheet2″)
    .Range(“E:E”).ClearContents
    .Range(“E1″).Delete xlUp
  End With
End Sub
 

データを配列に読み込んでFor~Nextで逐次チェックする方法

元のデータを配列(x)に読み込み、For~Nextで逐次チェックします。
配列でチェックしているため上の方法よりは短時間で処理できます。
コード例
Sub 配列()
  Dim x, y
  Dim myCnt As Long, myFlg As Boolean
  Dim i As Long, j As Long
    With Worksheets(“Sheet1″)
      x = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
    End With
    ReDim y(1 To UBound(x), 1 To 1)
    y(1, 1) = x(1, 1)
    myCnt = 1
    For i = LBound(x) To UBound(x)
      myFlg = False
      For j = 1 To myCnt
        If x(i, 1) = y(j, 1) Then myFlg = True: Exit For
      Next j
      If myFlg = False Then myCnt = myCnt + 1: y(myCnt, 1) = x(i, 1)
    Next i
    With Worksheets(“Sheet2″).
      Range(“C:C”).ClearContents
      .Range(“C1″).Resize(UBound(y), 1) = y
    End With
End Sub
 

For~Nextで逐次チェックする方法

もっとも基本的な方法で重複しているか否かを逐次調べ重複がなかったらSheet2へ追加していきます。
ここで書いている方法の中では最も時間がかかります。
コード例
Sub ループ()
 Dim lastRow1 As Long, lastRow2 As Long
 Dim i As Long, j As Long, myCnt As Long
    With Worksheets(“Sheet2″)
      .Range(“A:A”).ClearContents
      .Range(“A1″) = Worksheets(“Sheet1″).Range(“A1″).Value
      lastRow1 = Worksheets(“Sheet1″).Cells(Rows.Count, 1).End(xlUp).Row
      For i = 2 To lastRow1
        myCnt = 0
        lastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
        For j = 1 To lastRow2
          If .Cells(j, 1).Value = Worksheets(“Sheet1″).Cells(i, 1).Value Then
            Exit For
          Else
            myCnt = myCnt + 1
          End If
        Next j
        If myCnt = lastRow2 Then
          .Cells(lastRow2 + 1, 1).Value = Worksheets(“Sheet1″).Cells(i, 1).Value
        End If
      Next i
    End With
End Sub