前の質問を元に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.1
- 回答日時:
こんばんは!
なかなか回答がつかないようなので・・・
考え方として、後から削除するのではなくその「文字列」がない場合のみ「&」でつなげないようにする方が簡単だと思います。
他の回答者様のコードに手を付けるのは極力差し控えたいのですが、
>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列をひとまとめに
それを全部、併せたものを、「,」で区切って、G列にいれたいのです。
こういうってやはり無理でしょうか
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
No.2
- 回答日時:
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.3
- 回答日時:
前回の続きです。
前回のコードの後にコピー&ペーストしてください。
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」 とかいてあるかんじです。
No.4
- 回答日時:
続けておじゃまします。
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 …
申し訳ないのですが、検証していただけないでしょうか
No.5
- 回答日時:
親の仇のように顔を出します。
ファイルを拝見しました。
最初の質問よりかなり列数・列の配置が変わっていますね。
とりあえず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
となりました。Dの成分がはいりませんでした。 → A:54,B:43,D:3,K:65 このように成分ごとで
カンマと、成分名と数値の間にコロンがは入らないでしょうか・・?
また、出荷時 分類 入荷日付 備考 展開卸店 消費期限 内容 内容2 写真 予備
もいれれないでしょうか。
サンプルは下記のとおりです。
お時間を割いて下ってすいませんが宜しく御願い致します。
https://box.yahoo.co.jp/guest/viewer?sid=box-l-q …
No.6ベストアンサー
- 回答日時:
またまたお邪魔します。
乗りかかった船ですので、この際何とかご希望通りになるまでお付き合いできれば・・・
一つ一つ課題が増えてきているようですが・・・
>また、出荷時 分類 入荷日付 備考 展開卸店 消費期限 内容 内容2 写真 予備
>もいれれないでしょうか
に関してはどのようなデータか判らないので
とりあえず各行そのまま表示としています。
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': アプリケーション定義またはオブジェクト定義のエラーです。」
とでました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) vba 重複データ合算 5 2023/07/05 18:55
- Visual Basic(VBA) vbaを早くしたい 5 2022/09/09 10:58
- Excel(エクセル) VBAの指示の内容 昨日こちらでご教示頂いたのですが初心者な為、一つ一つの指示が何をやっているのかわ 2 2022/10/25 18:08
- Excel(エクセル) マクロで列を加えたら上手くいかなくなりました。 2 2022/05/23 17:59
- Visual Basic(VBA) VBA処理追加 こちらでご教示頂いたのですが回答完了させてしまいましたのでこちらからまた質問させてく 2 2022/10/27 09:57
- Visual Basic(VBA) オブジェクトが見つかりません 1 2023/06/24 19:43
- Excel(エクセル) なぜExit Subがあるのかわかりません 4 2023/02/19 12:34
- Visual Basic(VBA) VBA 別ブックからの転記の高速化について VBA 別ブックからの転記の高速化についてご教授下さい。 19 2022/07/26 13:07
- Visual Basic(VBA) VBA 請求書自動作成 3 2022/04/24 01:58
- Visual Basic(VBA) ユーザーフォームに2つのコンボボックス銀行名「ConboBox1」支店名を「ConboBox2」とし 4 2022/08/03 17:34
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセル初心者です 関数の入れ...
-
エクセルで二つの数字の小さい...
-
LOOKUP関数を使えばいいのでし...
-
PowerPointで表の1つの列だけ...
-
エクセルで最初のスペースまで...
-
エクセル 文字数 多い順 並...
-
VBAで文字列を数値に変換したい
-
2つのエクセルのデータを同じよ...
-
Excelで半角の文字を含むセルを...
-
エクセルの並び変えで、空白セ...
-
EXCELで 一桁の数値を二桁に
-
エクセルの表から正の数、負の...
-
Excel、市から登録している住所...
-
エクセルで文字が混じった数字...
-
A列がない・・・A列が非表示に...
-
エクセルの項目軸を左寄せにしたい
-
エクセルで一列おきに空白列を...
-
【ACCESS/必須条件とOR条件を組...
-
エクセルの隣り合う列のグループ化
-
エクセル(勝手に太字になる)
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルで二つの数字の小さい...
-
PowerPointで表の1つの列だけ...
-
エクセルで最初のスペースまで...
-
2つのエクセルのデータを同じよ...
-
エクセル(勝手に太字になる)
-
「B列が日曜の場合」C列に/...
-
エクセル 文字数 多い順 並...
-
EXCELで 一桁の数値を二桁に
-
エクセル 同じ値を探して隣の...
-
VBAで文字列を数値に変換したい
-
エクセルの並び変えで、空白セ...
-
Excelで半角の文字を含むセルを...
-
エクセルで文字が混じった数字...
-
Excel、市から登録している住所...
-
A列がない・・・A列が非表示に...
-
エクセルの表から正の数、負の...
-
[関数得意な方]教えて下さい・...
-
エクセルの項目軸を左寄せにしたい
-
エクセル 時間帯の重複の有無
-
Excelにてある膨大なデータを管...
おすすめ情報