[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『同じ作業番号の人の名前を抽出したい』（nao）
sheet1のC列、D列に作業番号、そしてE列に名前が入っており、Cの行を検索して同じ番号の名前とD列を検索して同じ番号の名前をsheet2に抽出したいと思います。
表としましては、データのある(sheet1)
C D E 4 作業番号 作業番号 作業者名
5 1 2 田中 6 3 4 佐藤 7 5 6 伊藤 8 7 8 吉田 9 3 9 加藤 10 10 2 林
と言う表があります。行は100行ほどあります。
抽出する(sheet2)に
A B 2 作業者名 作業番号
3 佐藤・加藤 3 4 田中・林 2
と抽出
説明不足かも知れませんが、
?@C列で重複している番号の人 ?AD列で重複している番号の人 をsheet2に表示したいと思います。
色々と検索した結果、やりたい事に似たコードがあったので、何とか出来ないかとやってみましたがダメでした。
このコードは全て同じである事となっていましたので・・・
Sub test()
Const タイトル行 = 1 Const 科目数 = 2
Dim endRow As Integer, writeRow As Integer, myCnt As Integer
Dim i As Integer, j As Integer, r As Integer
Dim myName As String
Dim myCHK As Boolean
Dim myArray
endRow = Cells(Rows.Count, 1).End(xlUp).Row
myArray = Range(Cells(1, 1), Cells(endRow, 科目数)).Value
Worksheets.Add
writeRow = 2
For i = タイトル行 To endRow
If i = タイトル行 Then
For r = 1 To 科目数
Cells(1, r).Value = myArray(タイトル行, r)
Next r
Else
If myArray(i, 科目数) <> "ck" Then
myCnt = 1
myName = myArray(i, 1)
For j = i + 1 To endRow
myCHK = True
For r = 2 To 科目数
If myArray(i, r) <> myArray(j, r) Then
myCHK = False
Exit For
End If
Next r
If myCHK = True Then
myName = myName & "・" & myArray(j, 1)
myArray(j, 科目数) = "ck"
myCnt = myCnt + 1
End If
Next j
If myCnt > 1 Then
Cells(writeRow, 1).Value = myName
For r = 2 To 科目数
Cells(writeRow, r).Value = myArray(i, r)
Next r
writeRow = writeRow + 1
End If
End If
End If
Next i
End Sub
これが検索して見つけたコードです。
どこを、どう変えれば？
すみません、ご教授下さい。
＜ 使用 Excel：Excel2010、使用 OS：Windows8 ＞
質問です。
C列の作業番号とD列の作業番号に重複はあるのでしょうか？
また、もし、重複がある場合には、その重複も含めて、出力するのでしょうか？
（C列の 2 と D列の 2 で ○○、□□ など）
（パオ〜〜ン） 2013/12/09(月) 17:19
衝突しましたが・・・
こういうことですか？
Sub 重複抽出()
Dim i As Long
Dim j As Long
Dim k As Long
Dim tbl As Variant
Dim res As Variant
tbl = Range("C5:E" & Cells(Cells.Rows.Count, "C").End(xlUp).Row).Value
ReDim res(1 To UBound(tbl, 1), 1 To 2)
j = 1
For k = 1 To 2
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl, 1)
If Not .exists(tbl(i, k)) Then
.Add tbl(i, k), tbl(i, 3)
Else
.Item(tbl(i, k)) = .Item(tbl(i, k)) & "・" & tbl(i, 3)
End If
Next i
For Each d In .keys
If UBound(Split(.Item(d), "・")) > 0 Then
res(j, 1) = d
res(j, 2) = .Item(d)
j = j + 1
End If
Next d
Sheets("sheet2").Range("A3").Resize(UBound(res, 1), 2) = res
End With
Next k
End Sub
C列のみの重複を出した後、続けてD列のみの重複を出力
（稲葉） 2013/12/09(月) 17:20
単純に
Sub test()
Dim e, s, txt As String, n As Long
n = 2
For Each e In Array("c", "d")
txt = e & "5:" & e & "500"
For Each s In Filter(Sheets("sheet1").Evaluate("transpose(if(countif(offset(" & txt & _
",0,0,row(1:500))," & txt & ")=2," & txt & ",char(2)))"), Chr(2), 0)
n = n + 1
Sheets("sheet2").Cells(n, 2).Value = s
Sheets("sheet2").Cells(n, 1).Value = _
Join(Filter(Sheets("sheet1").Evaluate("transpose(if(" & txt & "=" & s & _
",e5:e500,char(2)))"), Chr(2), 0), "・")
Next
Next
End Sub
（seiya） 2013/12/09(月) 17:35
有難うございます。
ご質問のC列とD列の重複はありません。
稲葉様
有難うございます。
すみません。私の説明不足でした。
C列、D列の両方で空欄のセルもありますので、それに対応して頂けると嬉しいのですが・・
その他はOKでした。
seiya様
有難うございます。
下記の部分で「型が一致しません」と出てしまいました。
Sheets("sheet2").Cells(n, 1).Value = _
Join(Filter(Sheets("sheet1").Evaluate("transpose(if(" & txt & "=" & s & _
",e5:e500,char(2)))"), Chr(2), 0), "・")
ここです。
皆様、早々に感謝しています。よろしくお願いします。
(nao) 2013/12/9 18:30
Hummm データ範囲にエラー値があることぐらいしか考えられないのですが？ B列は表示されていますか？ （seiya） 2013/12/09(月) 18:40
もしかして、sheet1のC/D列に数値・文字列混在？
Sub test()
Dim e, s, txt As String, n As Long
n = 2
For Each e In Array("c", "d")
txt = e & "5:" & e & "500"
For Each s In Filter(Sheets("sheet1").Evaluate("transpose(if(countif(offset(" & txt & _
",0,0,row(1:500))," & txt & ")=2," & txt & ",char(2)))"), Chr(2), 0)
n = n + 1
Sheets("sheet2").Cells(n, 2).Value = s
s = IIf(IsNumeric(s), s, Chr(34) & s & Chr(34))
Sheets("sheet2").Cells(n, 1).Value = _
Join(Filter(Sheets("sheet1").Evaluate("transpose(if(" & txt & "=" & s & _
",e5:e500,char(2)))"), Chr(2), 0), "・")
Next
Next
End Sub
（seiya） 2013/12/09(月) 18:57
>もしかして、sheet1のC/D列に数値・文字列混在？ はい。セルによっては、数字の前にアルファベット（例えばAA1とかCZ005)が入力されている所もあります。 あとは、空欄のセルもあります。 (nao) 2013/12/9 19:41
で、結果は？ （seiya） 2013/12/09(月) 20:09
seiya様
お世話になります。
すみません。結果ですが、作業番号のほうは正しく表示されていますが、名前のほうが表示されていません。
(nao) 2013/12/9 20:48
>作業番号のほうは正しく表示されていますが、名前のほうが表示されていません。
こちらでは作業番号が数値・文字列、空白の有無にかかわらず結果は出ています。 エラー無く最後まで実行されているのなら、Sheet1のE列が空白であっても Sheet2のA/B列に何らかの形でデータが出力されるはずです。 （seiya） 2013/12/09(月) 21:10
seiyaさんのほうがスマートですが、一応修正版（出力の時、名前と作業番号の列が逆だった・・・）
Sub 重複抽出()
Dim i As Long
Dim j As Long
Dim k As Long
Dim tmp As String
Dim tbl As Variant
Dim res As Variant
tbl = Range("C5:E" & Cells(Cells.Rows.Count, "C").End(xlUp).Row).Value
ReDim res(1 To UBound(tbl, 1), 1 To 2)
j = 1
For k = 1 To 2
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl, 1)
tmp = tbl(i, k)
If tmp <> "" Then
If Not .exists(tmp) Then
.Add tmp, tbl(i, 3)
Else
.Item(tmp) = .Item(tmp) & "・" & tbl(i, 3)
End If
End If
Next i
For Each D In .Keys
If UBound(Split(.Item(D), "・")) > 0 Then
res(j, 1) = .Item(D)
res(j, 2) = D
j = j + 1
End If
Next D
Sheets("sheet2").Range("A3").Resize(UBound(res, 1), 2) = res
End With
Next k
End Sub
（稲葉） 2013/12/10(火) 10:05
ご教授有難うございます。
結果についての返信が遅れて申し訳ありません。
エラー無く動きます。名前も表示されます。
しかし、sheet2のA列の一つのセルに良くわからないのが表示されます。
それがこれです。
「0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・」 これなんです。 何故？
あとはOKです。名前の列をE列からI列に変更しましたが、できました。
稲葉様
ご教授有難うございます。
エラー無く表示されます。OKでした。
少しコードの変更をお願いしたいのですが、
作業者名の列をE列からI列に変更したいのですが、少しいじってみましたが、上手くいきません。お手数ですが、変更をお願いします。
(nao)2013/12/11 10:31
> 「0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・0・」 これなんです。 何故？ 対象E列が空白ということ。
>作業者名の列をE列からI列
Sub test()
Dim e, s, txt As String, n As Long
n = 2
For Each e In Array("c", "d")
txt = e & "5:" & e & "500"
For Each s In Filter(Sheets("sheet1").Evaluate("transpose(if(countif(offset(" & txt & _
",0,0,row(1:500))," & txt & ")=2," & txt & ",char(2)))"), Chr(2), 0)
n = n + 1
Sheets("sheet2").Cells(n, 2).Value = s
s = IIf(IsNumeric(s), s, Chr(34) & s & Chr(34))
Sheets("sheet2").Cells(n, 1).Value = _
Join(Filter(Sheets("sheet1").Evaluate("transpose(if((" & txt & "=" & s & _
")*(i5:i500<>""""),i5:i500,char(2)))"), Chr(2), 0), "・")
Next
Next
End Sub
（seiya） 2013/12/11(水) 12:41
Dim i As Long
Dim j As Long
Dim k As Long
Dim tmp As String
Dim tbl As Variant
Dim res As Variant
tbl = Range("C5:I" & Cells(Cells.Rows.Count, "C").End(xlUp).Row).Value
ReDim res(1 To UBound(tbl, 1), 1 To 2)
j = 1
For k = 1 To 2
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl, 1)
tmp = tbl(i, k)
If tmp <> "" Then
If Not .exists(tmp) Then
.Add tmp, tbl(i, 7)
Else
.Item(tmp) = .Item(tmp) & "・" & tbl(i, 7)
End If
End If
Next i
For Each D In .Keys
If UBound(Split(.Item(D), "・")) > 0 Then
res(j, 1) = .Item(D)
res(j, 2) = D
j = j + 1
End If
Next D
Sheets("sheet2").Range("A3").Resize(UBound(res, 1), 2) = res
End With
Next k
End Sub
（稲葉） 2013/12/11(水) 16:55
「0・0・0・0・0・」も出なくなり解決しました。
正しく表示されます。
稲葉様
変更、有難うございました。
これで、無事解決致しました。
seiyaさん。稲葉さん。お世話になりました。
(nao) 2013/12/11 17:51
データのある(sheet1)
C F I 4 作業番号 作業番号 作業者名
5 1 2 田中 6 3 4 佐藤 7 5 6 伊藤 8 7 8 吉田 9 3 9 加藤 10 10 2 林
となります。
以前は、作業番号のセルがCとDセルでしたが、CとFに変更したいと思います。
使用しているコードは、
Sub 重複抽出()
Dim i As Long
Dim j As Long
Dim k As Long
Dim tmp As String
Dim tbl As Variant
Dim res As Variant
tbl = Range("C5:I" & Cells(Cells.Rows.Count, "C").End(xlUp).Row).Value
ReDim res(1 To UBound(tbl, 1), 1 To 2)
j = 1
For k = 1 To 2
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl, 1)
tmp = tbl(i, k)
If tmp <> "" Then
If Not .exists(tmp) Then
.Add tmp, tbl(i, 7)
Else
.Item(tmp) = .Item(tmp) & "・" & tbl(i, 7)
End If
End If
Next i
For Each D In .Keys
If UBound(Split(.Item(D), "・")) > 0 Then
res(j, 1) = .Item(D)
res(j, 2) = D
j = j + 1
End If
Next D
Sheets("sheet2").Range("A3").Resize(UBound(res, 1), 2) = res
End With
Next k
End Sub
となります。
よろしくお願いします。
(nao) 2014/8/19
For k = 1 To 2
ここの所で、1列目（C列の値）と2列目（D列の値）が順番に処理されています。
＞CとFに変更したいと思います。 でしたら、1列目と4列目が処理される様に変更の必要があると思います。 （HANA） 2014/08/23(土) 15:30
For K = 1 To 2を1 To 4にするとコード通り1列から４列全てがチェックされるし、 〜To〜のToを外すとエラーになるしで、CとKだけにするには？？で悩んでおります。
すみません。初心者用に、もう少し詳しく教えてくださいますか？
お願いします。
(nao) 2014/8/23 19:35
お世話になります。
For k = 1 To 2 >ここの所で、1列目（C列の値）と2列目（D列の値）が順番に処理されています。 >1列目と4列目が処理される様に変更の必要があると思います。
私なりに考えてみました。そこで、
For k = 1 To 4 Step 3
に変更したら、出来た気がします。
私は、 For k = 1 And 4とかだと思っていました。
(nao) 2014/8/24 10:48
＞ For k = 1 To 4 Step 3 ＞ に変更したら、出来た気がします。 そうですね。 今回の状況では、それが簡単だと思います。 （HANA） 2014/08/24(日) 12:10
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.