質問です

\test\の中に複数のCSVファイルがあります。

A列のA1からAnの複数文字列データをチェックしてB列にその重複個数1の数字だけを書き出すマクロをお願いします(重複なしが1になります)

A列
aaaaa
aaaaa
aaaaa
bbbbb
bbbbb
ccccc
eeeee

答え
A列    B列
aaaaa
aaaaa
aaaaa
bbbbb
bbbbb
ccccc     1
eeeee     1

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/11/23 17:45:43
  • 終了:2011/11/24 14:14:54

ベストアンサー

id:TransFreeBSD No.2

TransFreeBSD回答回数661ベストアンサー獲得回数2642011/11/24 10:23:55

ポイント100pt

上書きで良いのですよね?

Option Explicit

Sub Macro1()
    Const path = "\test"
    Const grab = "*.csv"
    Const keyCol = 1 ' column A
    Const countCol = 2 ' column B
    Dim dict As Object
    Dim file As String
    Dim last As Long
    Dim i As Long
    Set dict = CreateObject("Scripting.Dictionary")

    file = Dir(path & "\" & grab, vbNormal)
    Do While file <> ""
        dict.RemoveAll
        With Workbooks.Open(path & "\" & file)
            last = Cells(Rows.Count, keyCol).End(xlUp).Row
            For i = 1 To last
                dict.Item(Cells(i, keyCol).Value) = dict.Item(Cells(i, keyCol).Value) + 1
            Next
            For i = 1 To last
                If dict.Item(Cells(i, keyCol).Value) = 1 Then
                    Cells(i, countCol).Value = 1
                End If
            Next
            .Close SaveChanges:=True
        End With
        file = Dir
    Loop
End Sub

その他の回答(1件)

id:tomowa76 No.1

トモア回答回数1ベストアンサー獲得回数02011/11/23 23:01:41

複数ファイルなのですね、すみません!

id:TransFreeBSD No.2

TransFreeBSD回答回数661ベストアンサー獲得回数2642011/11/24 10:23:55ここでベストアンサー

ポイント100pt

上書きで良いのですよね?

Option Explicit

Sub Macro1()
    Const path = "\test"
    Const grab = "*.csv"
    Const keyCol = 1 ' column A
    Const countCol = 2 ' column B
    Dim dict As Object
    Dim file As String
    Dim last As Long
    Dim i As Long
    Set dict = CreateObject("Scripting.Dictionary")

    file = Dir(path & "\" & grab, vbNormal)
    Do While file <> ""
        dict.RemoveAll
        With Workbooks.Open(path & "\" & file)
            last = Cells(Rows.Count, keyCol).End(xlUp).Row
            For i = 1 To last
                dict.Item(Cells(i, keyCol).Value) = dict.Item(Cells(i, keyCol).Value) + 1
            Next
            For i = 1 To last
                If dict.Item(Cells(i, keyCol).Value) = 1 Then
                    Cells(i, countCol).Value = 1
                End If
            Next
            .Close SaveChanges:=True
        End With
        file = Dir
    Loop
End Sub

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません