[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『重複データをFGHに書き出す』（狭山）
こんばんは。 またお世話になります。 よろしくお願いいたします。
A B C D E F G H 1 番号 場所 個数 場所修正 個数修正 番号 場所 個数 2 1 東 京 100 東京 100 1 東京 100 3 2 神 奈 川 200 神奈川 200 7 東京 100 4 3 千 葉 300 千葉 300 *** *** *** 5 4 埼 玉 400 埼玉 400 2 神奈川 200 6 5 大 阪 500 大阪 500 8 神奈川 200 7 6 名 古 屋 10 名古屋 10 14 神奈川 200 8 7 東京 100 東京 100 *** *** *** 9 8 神奈川 200 神奈川 200 3 千葉 300 10 9 千葉 0 千葉 0 15 千葉 300 11 10 埼玉 400 埼玉 400 *** *** *** 12 11 大阪 500 大阪 500 4 埼玉 400 13 12 名古屋 20 名古屋 20 10 埼玉 400 14 13 東京 50 東京 50 16 埼玉 400 15 14 神奈川 200 神奈川 200 *** *** *** 16 15 千葉 300 千葉 300 5 大阪 500 17 16 埼玉 400 埼玉 400 11 大阪 500 18 17 大阪 50 大阪 50 19 18 名古屋 30 名古屋 30
上記のようなデータがあります。
B列とC列にデータが入っています。 B列のデータは漢字で書きましたが実際は『ひらがな・英数字・文字間に空白スペース』 などが入っています。（C列も同じです）
行いたい処理は １、B列C列ともに空白が入っていますがそれを削除してD列、E列に書き出す。 ２、DとEがセットとして列で重複したデータをF、G、H列に書き出す（F列はA列の番号です） のですが重複データを見やすくするため１行の間隔をあける（***が空白と見てください）
どうぞよろしくご教授下さい。
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
Option Explicit
Sub test()
Dim v
Dim dic As Object
Dim i As Long
Dim s As String
Dim k
Dim n As Long, m As Long
Set dic = CreateObject("Scripting.Dictionary")
ActiveSheet.UsedRange.Columns("F:H").Offset(1).ClearContents
v = Cells(1).CurrentRegion.Resize(, 3).Value
For i = 2 To UBound(v)
s = v(i, 2) & vbTab & v(i, 3)
s = Replace(s, " ", "")
If Not dic.exists(s) Then
Set dic(s) = CreateObject("System.Collections.ArrayList")
End If
dic(s).Add v(i, 1)
Next
n = 2
For Each k In dic
m = dic(k).Count
If m > 1 Then
With Cells(n, "F").Resize(m)
.Value = Application.Transpose(dic(k).toarray)
.Offset(, 1).Resize(, 2).Value = Split(k, vbTab)
n = n + m + 1
End With
End If
Next
End Sub
（マナ） 2017/08/01(火) 22:39
1) A:CをD:Fにコピペ 2) Eを選択して Ctl + H [検索する文字列] にスペース、[置換後の文字列]は入力無し、で全て置換 3) K2セルに =COUNTIFS($E$2:$E$19,E2,$F$2:$F$19,F2)>1 4) D1:F19を選択して、[データ] - [詳細設定] - [検索条件範囲]をクリックして K1:K2を選択して[OK] 5) 結果をコピーしてG1に貼り付け - [データ] - [クリア] 6) G:Iを数量で並べ替え
各場所ごとの空白は入りませんが... （ seiya） 2017/08/01(火) 22:40
Option Explicit
Sub test2()
Dim v
Dim dic As Object
Dim i As Long
Dim s As String
Dim k
Dim n As Long, m As Long
Set dic = CreateObject("Scripting.Dictionary")
ActiveSheet.UsedRange.Columns("F:H").Offset(1).ClearContents
v = Cells(1).CurrentRegion.Resize(, 3).Value
For i = 2 To UBound(v)
s = v(i, 2) & vbTab & v(i, 3)
s = Replace(s, " ", "")
If Not dic.exists(s) Then
Set dic(s) = CreateObject("System.Collections.ArrayList")
End If
dic(s).Add Array(v(i, 1), v(i, 2), v(i, 3))
Next
n = 2
For Each k In dic
m = dic(k).Count
If m > 1 Then
Cells(n, "F").Resize(m, 3).Value = _
Application.Transpose(Application.Transpose(dic(k).toarray))
n = n + m + 1
End If
Next
End Sub
（マナ） 2017/08/01(火) 23:09
（マナ） 2017/08/01(火) 23:12
（マナ） 2017/08/01(火) 23:16
vba
Sub test()
Dim a, i As Long, ii As Long, txt As String, e, n As Long, w, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Columns("f:h").ClearContents: n = 1
a = Cells(1).CurrentRegion.Value
For i = 2 To UBound(a, 1)
txt = Join(Array(Replace(a(i, 2), " ", ""), a(i, 3)), Chr(2))
If Not dic.exists(txt) Then
ReDim w(1 To 3, 1 To 1)
Else
w = dic(txt)
ReDim Preserve w(1 To 3, 1 To UBound(w, 2) + 1)
End If
For ii = 1 To 3
w(ii, UBound(w, 2)) = IIf(ii = 2, Replace(a(i, ii), " ", ""), a(i, ii))
Next
dic(txt) = w
Next
[f1:h1].Value = a
For Each e In dic
If UBound(dic(e), 2) > 1 Then
n = n + 1
Cells(n, "f").Resize(UBound(dic(e), 2), 3).Value = Application.Transpose(dic(e))
n = n + UBound(dic(e), 2)
End If
Next
End Sub
（ seiya） 2017/08/01(火) 23:43
（マナ）さんの修正の方で行いましたがC列とE列の個数が 1度目は大丈夫ののですが2回目にC列を変更してもE列は変化無しになってしまいます。 しかしFGHの答えは要望どおりに実行されます。 （ seiya）さんの 2017/08/01(火) 23:43の方ですが実行しましたところ FGHは要望どおりです。 しかし、DEには何も表示されませんでした。 DEに関しては、置換等で行えばできると思いますので明日にでも行ってみたいと思います。 明日の朝が早いため、ここで失礼させていただきます。
（狭山） 2017/08/02(水) 00:03
>しかし、DEには何も表示されませんでした。 DEにデータが必要なら
Sub test()
Dim a, i As Long, ii As Long, txt As String, e, n As Long, w, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Columns("f:h").ClearContents: n = 1
With Cells(1).CurrentRegion.Resize(, 3)
.Columns("b:c").Copy .Range("d1")
.Columns("d").Replace " ", "", 2
a = Application.Index(.Resize(, 5).Value, _
Evaluate("row(1:" & .Rows.Count & ")"), [{1,4,5}])
End With
For i = 2 To UBound(a, 1)
txt = Join(Array(a(i, 2), a(i, 3)), Chr(2))
If Not dic.exists(txt) Then
ReDim w(1 To 3, 1 To 1)
Else
w = dic(txt)
ReDim Preserve w(1 To 3, 1 To UBound(w, 2) + 1)
End If
For ii = 1 To 3
w(ii, UBound(w, 2)) = a(i, ii)
Next
dic(txt) = w
Next
[f1:h1].Value = a
For Each e In dic
If UBound(dic(e), 2) > 1 Then
n = n + 1
Cells(n, "f").Resize(UBound(dic(e), 2), 3).Value = _
Application.Transpose(dic(e))
n = n + UBound(dic(e), 2)
End If
Next
End Sub
（seiya） 2017/08/02(水) 11:05
実行してみました。DE列は表示されました。 しかし問題が出てしまいました。 B列の文字間の空白が全角だった場合に重複とみなされないみたいです。 ご教授お願いいたします。 （狭山） 2017/08/02(水) 16:23
1行追加してください。
.Columns("b:c").Copy .Range("d1")
.Columns("d").Replace " ", "", 2
.Columns("d").Replace " ", "", 2 '<---★ これ
（seiya） 2017/08/02(水) 16:27
（seiya）さま ありがとうございました。
完璧に出来ました。
.Columns("d").Replace " ", "", 2 の" "間に消したい文字等を入れ
使用させていただいています。
効率が良くスムーズで最高です。
今後もよろしくお願いいたします。
（狭山） 2017/08/02(水) 22:18
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.