以下のようにＡ列に16桁の数があります。これが何種類あるかをカウントし

質問

以下のようにＡ列に16桁の数があります。これが何種類あるかをカウントし（この場合は"５"）その数を行数として使用したいのです。Range(Range("B1"), Range("B5").Select
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　 ↑
　　　　　 　　　　　　　　　　　　　　　この矢印部分（B5の5）にそのカウントした数を使用したいのです。よろしくお願いします。

2009042505020101
2009042505020101
2009042505020102
2009042505020102
2009042505020102
2009042505020103
2009042505020103
2009042505020103
2009042505020103
2009042505020105
2009042505020109
2009042505020109
2009042505020109

回答No.6

hananoppo · ベストアンサー

ANo.4です。補足に対して回答していませんでしたので、追加します。
次のようにすればよいと思います。

Range("D2:F2").Copy
Range(Cells(3, 4), Cells(2 + Count, 4)).Select
ActiveSheet.Paste
Application.CutCopyMode = False

もし"D2:F2"も含めてカウントした行数分という意味であれば、2行目を次のように変更してください。

Range(Cells(3, 4), Cells(1 + Count, 4)).Select

お礼

ありがとうございました。無事思い通りに作動しました。

回答No.5

Wendy02

#2の回答者です。

>次にRange("D2:F2")にある数式をコピーして、D3から教えていただいたカウントした行数分
>貼り付けしたいのです。
---中略--
>としたのですが、ActiveSheet.Paste　のところがエラーになります。

それだけの情報ですと難しいですが、数式をコピーするということは以下のようになります。
言い換えると、同じ幅を平行移動させるわけです。左端の部分を揃えるか、全体の範囲を指定するか、どちらかです。

×　.Range("D3", .Cells(i, 3)).Select
　　↓
○　.Range("D3", .Cells(i, 4)).Select　'3を4に替える-左端をあわせる
または、
○ .Range("D3", .Cells(i, 6)).Select　'3を6に替える　6->F列 コピー先全体を広げる

という条件のみです。

'//
Sub Test3()
'フィルターオプションを利用する
　Dim r As Range
　Dim i As Long
　With ActiveSheet
　　Set r = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
　　r.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　i = Application.Subtotal(3, r)
　　.ShowAllData
　　If Application.CountIf(r, .Cells(1, 1)) > 1 Then
　　　i = i - 1 ((項目行がないので、1行目を項目としているか判定）
　　End If
　　.Range("D2:F2").Copy .Range("D3", .Cells(i, 6))　'追加部分
　End With
End Sub

回答No.4

hananoppo

ちょっと無駄なところがあったので修正します。

Sub Macro1()
Dim RowNum As Long
Dim Count As Long

RowNum = 1
Count = 1
Do
RowNum = RowNum + 1
If Cells(RowNum, 1).Value = "" Then Exit Do
If Cells(RowNum, 1).Value <> Cells(RowNum - 1, 1).Value Then Count = Count + 1
Loop

Range(Cells(1, 2), Cells(Count, 2)).Select
End Sub

補足

とてもシンプルなマクロですが、簡単に解説いただけないでしょうか。どこで（重複分を１として）カウントしているのかが良く分かりません。また若干多くカウントされているようです。

回答No.3

hananoppo

こんな感じでどうでしょう。

Sub Macro1()
Dim RowNum As Long
Dim Count As Long

RowNum = 1
Count = 1
Do
RowNum = RowNum + 1
If Cells(RowNum, 1).Value = "" Then
Exit Do
Else
If Cells(RowNum, 1).Value <> Cells(RowNum - 1, 1).Value Then Count = Count + 1
End If
Loop

Range(Cells(1, 2), Cells(Count, 2)).Select
End Sub

回答No.2

Wendy02

この質問のネックは、16桁を利用するということで、Excelでは、そのままでは数値として認知できませんので、それを文字列においてあげないといけません。

以下は、どれも満足したプロシージャではありませんが、あえて、VBAとして格好がついているのは、Test3()のプロシージャだと思います。

Sub Test1()
'関数を利用する
Dim r As Range
Dim i As Long
Dim cnt As Long
　Set r = Range("A1", Cells(Rows.Count, 1).End(xlUp))
　For i = 1 To r.Rows.Count
　 If i = Application.Match(r.Cells(i, 1).Value, r, 0) Then
　　　cnt = cnt + 1
　 End If
　Next
　Range("B1", Cells(cnt, 2)).Select
End Sub

Sub Test2()
'配列数式を利用する
Dim rng As Range
Dim sRng As String
　Set r = Range("A1", Cells(Rows.Count, 1).End(xlUp))
　sRng = r.Address
　i = Evaluate("SUM((MATCH(" & sRng & "," & sRng & ",0)=ROW(" & sRng & "))*1)")
　Range("B1", Cells(i, 2)).Select
End Sub

Sub Test3()
'フィルターオプションを利用する
　Dim r As Range
　Dim i As Long
　With ActiveSheet
　　Set r = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
　　r.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　i = Application.Subtotal(3, r)
　　.ShowAllData
　　If Application.CountIf(r, .Cells(1, 1)) > 1 Then
　　　i = i - 1 ((項目行がないので、1行目を項目としているか判定）
　　End If
　　.Range("B1", .Cells(i, 2)).Select
　End With
End Sub

補足

Sub Test3()
を使用させていただきました。ありがとうございます。ただ、次の問題が発生しました。
引き続きお助け下さい。
下から3行目の
　.Range("B1", .Cells(i, 2)).Select
の範囲に数式を貼り付けます。ここまではできました。
次にRange("D2:F2")にある数式をコピーして、D3から教えていただいたカウントした行数分
貼り付けしたいのです。

Range("D2:F2").Select
Selection.Copy
　.Range("D3", .Cells(i, 3)).Select
ActiveSheet.Paste

としたのですが、ActiveSheet.Paste　のところがエラーになります。
是非、よろしくお願いします。

回答No.1

GOCHISOUda

Sub 教えて()
Range("C1").FormulaArray = _
"=SUM(IF(FREQUENCY(A1:A13, A1:A13)>0, 1, 0))"
r = Range("C1")

アドレス = "B" & r
Range(アドレス).Activate
End Sub

補足

早速の御回答ありがとうございます。
=SUM(IF(FREQUENCY(A1:A13, A1:A13)>0, 1, 0))
の部分が正しい値（ここでは「５」）を出してくれないのですが、.....。