複数行にまたがっているデーターを一つの行に 2

前の質問を元にVBAを改造をしています。
（前の質問のURL:http://oshiete.goo.ne.jp/qa/8189711.html)
改造したものが以下です。

Sub sample()
Dim OWS As Worksheet, NWS As Worksheet
Dim myKey As String, myRow As Long, TRow As Long
Dim i As Long, j As Long

Application.DisplayAlerts = False

For Each NWS In Worksheets
If NWS.Name = "結果" Then NWS.Delete
Next

Set OWS = Sheets("Sheet1")
Set NWS = Worksheets.Add
NWS.Name = "結果"

For i = 1 To OWS.Cells(Rows.Count, 1).End(xlUp).Row
myKey = OWS.Cells(i, 1) & OWS.Cells(i, 2)

For j = 5 To OWS.Cells(i, Columns.Count).End(xlToLeft).Column
myKey = myKey & OWS.Cells(i, j)
Next j

myRow = WorksheetFunction.CountA(NWS.Columns("A:A")) + 1

If NWS.Columns("E:E").Find(What:=myKey, LookAt:=xlWhole) Is Nothing Then
NWS.Cells(myRow, 1) = OWS.Cells(i, 1)
NWS.Cells(myRow, 2) = OWS.Cells(i, 2)
NWS.Cells(myRow, 3) = OWS.Cells(i, 3)
NWS.Cells(myRow, 4) = OWS.Cells(i, 4)
NWS.Cells(myRow, 5) = myKey
Else
TRow = NWS.Columns("E:E").Find(What:=myKey, LookAt:=xlWhole).Row
NWS.Cells(TRow, 3) = NWS.Cells(TRow, 3) & "," & OWS.Cells(i, 3)
NWS.Cells(TRow, 4) = NWS.Cells(TRow, 4) & "," & OWS.Cells(i, 4)
End If
Next i

Call 同一項目削除

NWS.Columns("E:E").Delete

Application.DisplayAlerts = True
End Sub

Sub 同一項目削除()
Dim a, myDic, x
Dim h As Range
Set myDic = CreateObject("Scripting.Dictionary")
On Error Resume Next
' Range("A:A").ClearContents

For Each h In Range("E1:E" & Range("E65536").End(xlUp).Row)
a = Split(Replace(h, "　", " "), ",")
For Each x In a
myDic.Add x, ","
Next
h.Offset(0, 0) = Join(myDic.keys, ",")
myDic.RemoveAll
Next
End Sub



これをコンパクトにできますでしょうか？

No.6 ベストアンサー 回答者： tom04 回答日時： 2013/07/30 20:31

またまたお邪魔します。

乗りかかった船ですので、この際何とかご希望通りになるまでお付き合いできれば・・・

一つ一つ課題が増えてきているようですが・・・
＞また、出荷時　　分類　　入荷日付　　備考　　展開卸店　　消費期限　　内容　　内容２　　写真　　予備
＞もいれれないでしょうか

に関してはどのようなデータか判らないので
とりあえず各行そのまま表示としています。

Sub Sample5()
Dim i As Long, j As Long, k As Long, n As Long, endRow As Long, lastRow As Long, endCol As Long
Dim str As String, buf As String, wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With wS1
endRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A:A").Insert
.Range("A1") = "ダミー"
With Range(.Cells(2, 1), .Cells(endRow, 1))
.Formula = "=B2&C2"
.Value = .Value
End With
Range(.Cells(1, 1), .Cells(endRow, 1)).AdvancedFilter Action:=xlFilterInPlace, unique:=True
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
endCol = .Cells(1, Columns.Count).End(xlToLeft).Column
Range(.Cells(1, 2), .Cells(endRow, endCol)).Copy wS2.Cells(1, 1)
.ShowAllData
.Range("A:A").Delete
wS2.Range("J:R").Delete
wS2.Range("I1") = "成分"
For i = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, 1)
.Range("A1").AutoFilter field:=2, Criteria1:=wS2.Cells(i, 2)
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(2, 1), .Cells(lastRow, 18)).Copy wS3.Cells(1, 1) '←R列まで
For k = 1 To wS3.Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To 8 'C～H列まで
If wS3.Cells(k, j) <> "" And InStr(wS2.Cells(i, j), wS3.Cells(k, j)) = 0 Then
wS2.Cells(i, j) = wS2.Cells(i, j) & "," & wS3.Cells(k, j)
End If
Next j
For n = 9 To 18 Step 2 'I～R列まで
With wS3.Cells(k, n)
If .Value <> "" Then
str = .Value & ":" & .Offset(, 1)
If InStr(buf, str) = 0 Then
buf = buf & str & ","
End If
End If
End With
Next n

Next k
If Len(buf) > 0 Then
wS2.Cells(i, 9) = Left(buf, Len(buf) - 1)
End If
buf = ""
wS3.Cells.Clear
Next i
.AutoFilterMode = False
wS2.Columns.AutoFit
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
End Sub

少しは解決に近づけたでしょうか？m（_ _）m

この回答への補足

このコードで実行してみました。
すると「実行時エラー’1004'： アプリケーション定義またはオブジェクト定義のエラーです。」
とでました。　

補足日時：2013/07/31 09:25

この回答へのお礼

間違えてました。シートのコードに貼り付けてやってしまっていました。ちゃんと動くきました。
ありがとうございます！！

お礼日時：2013/07/31 09:42

No.5 回答者： tom04 回答日時： 2013/07/30 14:52

親の仇のように顔を出します。

ファイルを拝見しました。
最初の質問よりかなり列数・列の配置が変わっていますね。
とりあえずR列までのデータ表示としています。

尚、注意点として、こちらでファイルを開くとSheet1だけみたいですので
Sheet3を作業用のSheetとして使用し、Sheet2に表示するようにしていますので
Sheet2とSheet3はSheet名を間違えないようにして挿入しておいてください。

Sub Sample4()
Dim i As Long, j As Long, k As Long, n As Long, endRow As Long, lastRow As Long
Dim buf As String, wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With wS1
endRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A:A").Insert
.Range("A1") = "ダミー"
With Range(.Cells(2, 1), .Cells(endRow, 1))
.Formula = "=B2&C2"
.Value = .Value
End With
Range(.Cells(1, 1), .Cells(endRow, 1)).AdvancedFilter Action:=xlFilterInPlace, unique:=True
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(1, 2), .Cells(endRow, 9)).Copy wS2.Cells(1, 1)
.ShowAllData
.Range("A:A").Delete
For i = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, 1)
.Range("A1").AutoFilter field:=2, Criteria1:=wS2.Cells(i, 2)
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(2, 1), .Cells(lastRow, 18)).Copy wS3.Cells(1, 1) '←R列まで
For k = 1 To wS3.Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To 8 'C～H列まで
If wS3.Cells(k, j) <> "" And InStr(wS2.Cells(i, j), wS3.Cells(k, j)) = 0 Then
wS2.Cells(i, j) = wS2.Cells(i, j) & "," & wS3.Cells(k, j)
End If
Next j
For n = 9 To 18 'I～R列まで
If wS3.Cells(k, n) <> "" And InStr(buf, wS3.Cells(k, n)) = 0 Then '☆
'↑　成分コードの重複なしで表示するようにしています。
buf = buf & wS3.Cells(k, n) & ","
End If
Next n
Next k
If Len(buf) > 0 Then
wS2.Cells(i, 9) = Left(buf, Len(buf) - 1)
End If
buf = ""
wS3.Cells.Clear
Next i
.AutoFilterMode = False
wS2.Columns.AutoFit
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
End Sub

※　A・B列データはきちっと並んでいなくても構いません。
※　「☆」の行を見てもらうとお判りだと思いますが、
成分列で重複するものは表示しないようにしています。m（_ _）m

この回答への補足

当初より随分とかえてしまってすいません。

今、このコードでやると、成分がA,54,B,43,D,K,65
となりました。Ｄの成分がはいりませんでした。　　→　A:54,B:43,D:3,K:65　このように成分ごとで
カンマと、成分名と数値の間にコロンがは入らないでしょうか・・？

また、出荷時　　分類　　入荷日付　　備考　　展開卸店　　消費期限　　内容　　内容２　　写真　　予備
もいれれないでしょうか。
サンプルは下記のとおりです。
お時間を割いて下ってすいませんが宜しく御願い致します。


https://box.yahoo.co.jp/guest/viewer?sid=box-l-q …

補足日時：2013/07/30 15:15

No.4 回答者： tom04 回答日時： 2013/07/29 20:45

続けておじゃまします。

Sheet1の成分（10列分）はG列1列にまとめてもよい訳ですね？
そうであればもっと簡単だと思います。
尚、中には空白セルもあるみたいなので、
もう一度コードを載せてみます。

Sub Sample3()
Dim i As Long, j As Long, k As Long, n As Long, endRow As Long, lastRow As Long
Dim buf As String, wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With wS1
endRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A:A").Insert
.Range("A1") = "ダミー"
With Range(.Cells(2, 1), .Cells(endRow, 1))
.Formula = "=B2&C2"
.Value = .Value
End With
Range(.Cells(1, 1), .Cells(endRow, 1)).AdvancedFilter Action:=xlFilterInPlace, unique:=True
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(1, 2), .Cells(endRow, 7)).Copy wS2.Cells(1, 1)
.ShowAllData
.Range("A:A").Delete
For i = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, 1)
.Range("A1").AutoFilter field:=2, Criteria1:=wS2.Cells(i, 2)
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(2, 1), .Cells(lastRow, 16)).Copy wS3.Cells(1, 1)
For k = 1 To wS3.Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To 6
If wS3.Cells(k, j) <> "" And InStr(wS2.Cells(i, j), wS3.Cells(k, j)) = 0 Then
wS2.Cells(i, j) = wS2.Cells(i, j) & "," & wS3.Cells(k, j)
End If
Next j
For n = 7 To 16
If wS2.Cells(i, 7) <> "" Then
buf = wS2.Cells(i, 7)
End If
If wS3.Cells(k, n) <> "" Then
buf = buf & "," & wS3.Cells(k, n)
End If
Next n
Next k
wS2.Cells(i, 7) = Mid(buf, 2, Len(buf) - 1)
buf = ""
wS3.Cells.Clear
Next i
.AutoFilterMode = False
wS2.Columns.AutoFit
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
End Sub

※　E・F列に関しては異なるデータがある場合、「品名」や「サイズ」の列のように
同一セルに表示するようにしています。

今度はどうでしょうか？m（_ _）m

この回答への補足

やってみたのですが、エラーになってしまいます・・・

一応、元のリストをアップしました。
https://box.yahoo.co.jp/guest/viewer?sid=box-l-q …
申し訳ないのですが、検証していただけないでしょうか

補足日時：2013/07/30 10:15

No.3 回答者： tom04 回答日時： 2013/07/28 22:36

前回の続きです。

前回のコードの後にコピー＆ペーストしてください。

For i = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, 1)
.Range("A1").AutoFilter field:=2, Criteria1:=wS2.Cells(i, 2)
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(2, 1), .Cells(lastRow, 16)).Copy wS3.Cells(1, 1)
For k = 1 To wS3.Cells(Rows.Count, 1).End(xlUp).Row
If InStr(wS2.Cells(i, 3), wS3.Cells(k, 3)) = 0 Then
wS2.Cells(i, 3) = wS2.Cells(i, 3) & "," & wS3.Cells(k, 3)
End If
If InStr(wS2.Cells(i, 4), wS3.Cells(k, 4)) = 0 Then
wS2.Cells(i, 4) = wS2.Cells(i, 4) & "," & wS3.Cells(k, 4)
End If
If InStr(wS2.Cells(i, 5), wS3.Cells(k, 5)) = 0 Then
wS2.Cells(i, 5) = wS2.Cells(i, 5) & "," & wS3.Cells(k, 5)
End If
If InStr(wS2.Cells(i, 6), wS3.Cells(k, 6)) = 0 Then
wS2.Cells(i, 6) = wS2.Cells(i, 6) & "," & wS3.Cells(k, 6)
End If
If InStr(wS2.Cells(i, 7), wS3.Cells(k, 7)) = 0 Then
wS2.Cells(i, 7) = wS2.Cells(i, 7) & "," & wS3.Cells(k, 7)
End If
If InStr(wS2.Cells(i, 7), wS3.Cells(k, 8)) = 0 Then
wS2.Cells(i, 7) = wS2.Cells(i, 7) & "," & wS3.Cells(k, 8)
End If
If InStr(wS2.Cells(i, 8), wS3.Cells(k, 9)) = 0 Then
wS2.Cells(i, 8) = wS2.Cells(i, 8) & "," & wS3.Cells(k, 9)
End If
If InStr(wS2.Cells(i, 8), wS3.Cells(k, 10)) = 0 Then
wS2.Cells(i, 8) = wS2.Cells(i, 8) & "," & wS3.Cells(k, 10)
End If
If InStr(wS2.Cells(i, 9), wS3.Cells(k, 11)) = 0 Then
wS2.Cells(i, 9) = wS2.Cells(i, 9) & "," & wS3.Cells(k, 11)
End If
If InStr(wS2.Cells(i, 9), wS3.Cells(k, 12)) = 0 Then
wS2.Cells(i, 9) = wS2.Cells(i, 9) & "," & wS3.Cells(k, 12)
End If
If InStr(wS2.Cells(i, 10), wS3.Cells(k, 13)) = 0 Then
wS2.Cells(i, 10) = wS2.Cells(i, 10) & "," & wS3.Cells(k, 13)
End If
If InStr(wS2.Cells(i, 10), wS3.Cells(k, 14)) = 0 Then
wS2.Cells(i, 10) = wS2.Cells(i, 10) & "," & wS3.Cells(k, 14)
End If
If InStr(wS2.Cells(i, 11), wS3.Cells(k, 15)) = 0 Then
wS2.Cells(i, 11) = wS2.Cells(i, 11) & "," & wS3.Cells(k, 15)
End If
If InStr(wS2.Cells(i, 11), wS3.Cells(k, 16)) = 0 Then
wS2.Cells(i, 11) = wS2.Cells(i, 11) & "," & wS3.Cells(k, 16)
End If
Next k
wS3.Cells.Clear
Next i
.AutoFilterMode = False
wS2.Columns.AutoFit
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m（_ _）m

この回答への補足

何も入っていないセルにまで「,」がでるのですが、これは回避できないでしょうか？
また、Cells(i, 7)の中に、Cells(i, 8)～Cells(i, 16)をいれたいのですがですができないんでしょうか？
つまりは、　Cells(i, 7)のセルに「成分A:10,成分B:10,成分C:10,成分D:10,成分E:10,成分F:10」　　とかいてあるかんじです。　　

補足日時：2013/07/29 13:13

No.2 回答者： tom04 回答日時： 2013/07/28 22:35

No.1です。

泥臭くやってみました。
Sheet3を作業用のSheetとして使用していますので、
Sheet3はまっさらな状態にしておいてください。

尚、文字数制限の関係で一度では無理だと思いますので、、
コードを2回に分けて投稿します。
標準モジュールです。

Sub Sample2()
Dim i As Long, j As Long, k As Long, endRow As Long, lastRow As Long
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With wS1
endRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A:A").Insert
.Range("A1") = "ダミー"
With Range(.Cells(2, 1), .Cells(endRow, 1))
.Formula = "=B2&C2"
.Value = .Value
End With
Range(.Cells(1, 1), .Cells(endRow, 1)).AdvancedFilter Action:=xlFilterInPlace, unique:=True
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(1, 2), .Cells(endRow, 16)).Copy wS2.Cells(1, 1)
.ShowAllData
.Range("A:A").Delete
For j = 16 To 8 Step -2
wS2.Columns(j).Delete
Next j

No.1 回答者： tom04 回答日時： 2013/07/25 23:19

こんばんは！

なかなか回答がつかないようなので・・・

考え方として、後から削除するのではなくその「文字列」がない場合のみ「＆」でつなげないようにする方が簡単だと思います。

他の回答者様のコードに手を付けるのは極力差し控えたいのですが、

＞NWS.Cells(TRow, 3) = NWS.Cells(TRow, 3) & "," & OWS.Cells(i, 3)
＞NWS.Cells(TRow, 4) = NWS.Cells(TRow, 4) & "," & OWS.Cells(i, 4)

の2行を
If InStr(NWS.Cells(TRow, 3), OWS.Cells(i, 3)) = 0 Then
NWS.Cells(TRow, 3) = NWS.Cells(TRow, 3) & "," & OWS.Cells(i, 3)
End If
If InStr(NWS.Cells(TRow, 4), OWS.Cells(i, 4)) = 0 Then
NWS.Cells(TRow, 4) = NWS.Cells(TRow, 4) & "," & OWS.Cells(i, 4)
End If

のようにしてみたらどうなりますか？
検証していませんので、ご希望通りにならなかったらごめんなさいね。

※　本件とは関係ないのですが、前回の質問は解決済みのようですので、
そろそろ締め切られた方が良いとおもいますよ。m（_ _）m

この回答への補足

もうひとつ新たに問題があって　G列H列をひとまとめに　I列J列をひとまとめに　K列とL列をひとまとめに
M列とN列をひとまとめに　O列とP列をひとまとめに

それを全部、併せたものを、「,」で区切って、Ｇ列にいれたいのです。
こういうってやはり無理でしょうか

A列　　　B列　　　C列　　　D列　　　E列　　　F列　　　G列　　　H列　　　I列　　　J列　　　K列　　　L列　　　M列　　　N列　　　O列　　　P列
ナマエ　　　産地　　　品名　　　サイズ　　　価格　　　税込み価格　　　成分1　　　成分1量%　　　成分2　　　成分2量%　　　成分3　　　成分3量%　　　成分4　　　成分4量%　　　成分5　　　成分5量%
佐藤　　　北海道　　　りんご　　　S　　　100　　　105　　　成分A　　　10　　　成分B　　　10　　　成分C　　　10　　　成分D　　　10　　　成分E　　　10
佐藤　　　北海道　　　りんご　　　M　　　100　　　105　　　成分A　　　10　　　成分B　　　10　　　成分C　　　10　　　成分D　　　10　　　成分E　　　10
佐藤　　　北海道　　　ばなな　　　L　　　100　　　105　　　成分A　　　10　　　成分B　　　10　　　成分C　　　10　　　成分D　　　10　　　成分E　　　10
伊藤　　　東京　　　いちご　　　S　　　100　　　105　　　成分A　　　10　　　成分B　　　10　　　成分C　　　10　　　成分D　　　10　　　成分E　　　10
伊藤　　　東京　　　ばなな　　　M　　　100　　　105　　　成分A　　　10　　　成分B　　　10　　　成分C　　　10　　　成分D　　　10　　　成分E　　　10


↓↓↓↓↓↓↓↓↓↓↓↓これに↓↓↓↓↓↓↓↓↓↓↓↓

A列　　　B列　　　C列　　　D列　　　E列　　　F列　　　G列　　　　　　　　　　　　　　　　　　　　　　　　　　　
ナマエ　　　産地　　　品名　　　サイズ　　　価格　　　税込み価格　　　成分　　　　　　　　　　　　　　　　　　　　　　　　　　　
佐藤　　　北海道　　　りんご,ばなな　　　S,M,L　　　100　　　105　　　成分A:10,成分B:10,成分C:10,成分D:10,成分E:10,成分F:10　　　　　　　　　　　　　　　　　　　　　　　　　　　
伊藤　　　東京　　　いちご,ばなな　　　S,M　　　100　　　105　　　成分A:10,成分B:10,成分C:10,成分D:10,成分E:10,成分F:10　　　　　　　　　　　　　　　　　　　　　　　　　　　

補足日時：2013/07/26 15:16