Excel VBA 質問スレ Part76

2022/05/01(日) 02:23:41.78

!extend:checked:vvvvv:1000:512
!extend:checked:vvvvv:1000:512
↑2行に減ってるけど、同じ内容を3行に増やして貼り付けること

ExcelのVBAに関する質問スレ
コード書き込みや作成依頼もOK

次スレは>>980が立てること
無理なら細かく安価指定

※前スレ
Excel VBA 質問スレ Part75
https://mevius.5ch.net/test/read.cgi/tech/1644384272/

VIPQ2_EXTDAT: checked:vvvvv:1000:512:: EXT was configured

2022/07/15(金) 00:00:11.50

>>973
どの辺りが？
それとも気持ち悪いって言いたかっただけ？

2022/07/15(金) 00:30:48.57

なんでスペースがアンダーバーなんだとは思うな
俺も見た目が受け付けなかったわ

2022/07/15(金) 00:48:33.55

いや、そもそも自作自演だろ

2022/07/15(金) 01:18:26.31

Sub Main()
　　Dim a As String
　　Dim i As Long
　　Dim j As Long
　　For i = 1 To 5
　　　　a = Cells(i, 1)
　　　　For j = 1 To 5
　　　　　　If i <> j Then a = CutWord(a, Cells(j, 1))
　　　　Next
　　　　Cells(i, 2) = a
　　Next
End Sub

Function CutWord(a As String, b As String) As String
　　Dim aa() As String
　　Dim bb() As String
　　Dim c As String
　　Dim i As Long
　　aa = Split(a, " ")
　　bb = Split(b, " ")
　　For i = LBound(aa) To UBound(aa)
　　　　Dim j As Long
　　　　For j = LBound(bb) To UBound(bb)
　　　　　　If aa(i) = bb(j) Then Exit For
　　　　Next
　　　　If j > UBound(bb) Then
　　　　　　If c <> "" Then c = c & " "
　　　　　　c = c & aa(i)
　　　　End If
　　Next
　　CutWord = c
End Function

**964** (ｽｯｯﾌﾟ Sd43-CglE) · 2022/07/15(金) 02:31:06.28

早速ご回答いただいた皆様、ありがとうございました！
ほぼ思い通りの結果を得ることができました。

ちなみにですが、
例えばA6に「DOG CAT RABBIT COW BEAR」というデータがある場合、
各単語がどれとも重複していないため「DOG CAT RABBIT COW BEAR」そのまま5単語が残ります。

各データのユニークな単語を最小数で残すことは可能でしょうか？
下記のような形です。

A
1 RED BLUE APPLE
2 RED BLUE BANANA
3 RED BLUE GREEN ORANGE
4 RED BLUE YELLOW WHITE GRAPE
5 RED BLUE WHITE CHERRY
6 DOG CAT RABBIT COW BEAR

↓

B
1 APPLE
2 BANANA
3 GREEN ORANGE
4 YELLOW GRAPE
5 CHERRY
6 DOG

度々申し訳ございませんが、よろしくお願いいたします。

2022/07/15(金) 02:36:26.14

いつものあいつだぞ

2022/07/15(金) 06:01:47.46

最小限の定義が不明

**デフォルトの名無しさん** (ｽﾌｯ Sd43-TkQT) · 2022/07/15(金) 07:03:30.04

Sub Main()
　　Dim a As String
　　Dim i As Long, j As Long
　　Dim last As Long
　　last = Cells(Rows.Count, 1).End(xlUp).Row
　　For i = 1 To last
　　　　a = Cells(i, 1)
　　　　For j = 1 To last
　　　　　　If i <> j Then a = CutWord(a, Cells(j, 1))
　　　　Next j
　　　　Cells(i, 2) = a
　　Next i
End Sub

Function CutWord(a As String, b As String) As String
　　Dim aa() As String
　　Dim bb() As String
　　Dim c As String
　　Dim i As Long, j As Long
　　aa = Split(a, " ")
　　bb = Split(b, " ")
　　For i = LBound(aa) To UBound(aa)
　　　　For j = LBound(bb) To UBound(bb)
　　　　　　If aa(i) = bb(j) Then Exit For
　　　　Next j
　　　　If j > UBound(bb) Then c = c & aa(i) & " "
　　Next i
　　CutWord = Trim(c)
End Function

2022/07/15(金) 07:30:27.66

俺のコードをいじってくれてうれしいが
Valueとったり改行いじったりしてるだけで行数減らしてるだけなんて結局マイルールのこだわりを主張してるだけなんだよな
こんな方法あるぜってのが見たいわ

>>978
6が「DOG」になる最小数という意味が不明
先頭の単語を返すだけならCutWordの最後でaとcが同じ値になったらaa(LBound(aa))を返すようにすればいいのでは

2022/07/15(金) 07:47:41.51

value取るのは改悪で草

2022/07/15(金) 08:08:12.42

>>964
複数回現れる単語を削除すればいいのか？
Sub X964()
Dim Sheet As Worksheet: Set Sheet = ...
Dim Dictionary As Object: Set Dictionary = CreateObject("Scripting.Dictionary")
Dim LastRow As Long: LastRow = SheetSheet.Cells(Rows.Count, "A").End(xlUp).Row
Dim Row As Long
For Row = 1 To LastRow
Dim Word As Variant
For Each Word In Split(Sheet.Cells(Row, "A").Value, " ")
If Dictionary.Exists(Word) Then
Dictionary(Word) = Dictionary(Word) + 1
Else
Dictionary.Add Word, 1
End If
Next
Next
For Row = 1 To LastRow
Dim Uniques As String: Uniques = ""
For Each Word In Split(Sheet.Cells(Row, "A").Value, " ")
If 1 < Dictionary(Word) Then
If Uniques = "" Then
Uniques = Word
Else
Uniques = Uniques & " " & Word
End If
End If
Next
Sheet.Cells(Row, "B").Value = Uniques
Next
End Sub

2022/07/15(金) 08:10:06.84

>>973
気持ち悪いとは思わないけどちょっと非効率かなとは思う

2022/07/15(金) 08:49:49.31

そのコードカッケェ！

**デフォルトの名無しさん** (ｽﾌｯ Sd43-TkQT) · 2022/07/15(金) 09:42:45.28

Sub sample3()
　　Dim r As Long
　　Dim z As Long '最終行
　　Dim s As String '全データ
　　Dim a() As String '単語リスト
　　Dim i As Long
　　z = Cells(Rows.Count, 1).End(xlUp).Row
　　For r = 1 To z
　　　　Cells(r, 2) = Cells(r, 1)
　　　　s = s & Cells(r, 1) & " "
　　Next r
　　a = Split(s, " ")
　　For i = LBound(a) To UBound(a)
　　　　If Len(s) - Len(a(i)) > Len(Replace(s, a(i), "")) Then '2回以上出てくるか
　　　　　　For r = 1 To z
　　　　　　　　Cells(r, 2) = Trim(Replace(Cells(r, 2), a(i), "")) '各セルから削除
　　　　　　Next r
　　　　End If
　　Next i
End Sub

2022/07/15(金) 09:47:20.06

効率どうこう言う前に重複した単語がでるような関数はどうかと思うのｗ

2022/07/15(金) 13:22:47.81

ここでRuby馬鹿がRubyではこうなるとか書くのは見えている

2022/07/15(金) 19:00:37.71

オレンジ色のオレンジはどうなの？

2022/07/15(金) 19:14:37.65

どんなに良コード書いても難癖付けられるのがこのスレ

2022/07/16(土) 02:37:29.28

userformをshowした直後にunloadするとexcelが落ちるのは何とかならんかのぉ
hideじゃだめなんじゃunloadじゃないと

2022/07/16(土) 07:52:34.81

UserForm1.Show vbModeless
Unload UserForm1

って意味なら、別に落ちなかったけど

2022/07/16(土) 08:52:29.38

逆になんでhideじゃダメなの

2022/07/16(土) 13:26:34.40

とりあえずEXCELが落ちるっていうコードと環境出せ
話はそれからだ

2022/07/16(土) 18:00:44.38

>>978
Ruby で作った

require "csv"

input_str = <<"EOT"
RED,BLUE,APPLE
RED,BLUE,BANANA
RED,BLUE,GREEN,ORANGE
RED,BLUE,YELLOW,WHITE,GRAPE
RED,BLUE,WHITE,CHERRY
DOG,CAT,RABBIT,COW,BEAR
EOT

csv = CSV.new( input_str )
input_ary = csv.read # 2次元配列

# 各単語の出現回数を数える。Hash の初期値は、0
hash = input_ary.each_with_object( Hash.new( 0 ) ) { |row, hash|
row.each { |word| hash[ word ] += 1 }
}

# 出現回数が2以上の単語を削除する
input_ary.map! { |row|
row.delete_if { |word| hash[ word ] >= 2 }
row
}

# 2次元配列を、CSV 文字列に変換する
csv_str = input_ary.map( &:to_csv ).join
puts csv_str

2022/07/16(土) 19:45:04.74

>>996
廃止決定した言語じゃん

2022/07/17(日) 00:22:00.69

あんたら色んな言語を習得していてエリートなんだな？
５ちゃんねるなんかにいてもったいねーわ

2022/07/17(日) 02:44:22.32

>>995
993と同じ、2行だけ
エクセルは2013

>>994
閉じたWebbrowserを再表示する方法がわからないので仕方なく

2022/07/17(日) 04:50:23.78

こいつの書くコード、rubyとしてもクソコードなのがほんとひどい

**1001** · Over 1000

このスレッドは１０００を超えました。
新しいスレッドを立ててください。
life time: 77日 2時間 26分 42秒