!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
Excel VBA 質問スレ Part76
レス数が1000を超えています。これ以上書き込みはできません。
1デフォルトの名無しさん (ﾌﾞｰｲﾓ MMff-XZ6m)
2022/05/01(日) 02:23:41.78ID:2t63WK/jM970デフォルトの名無しさん (ｽｯｯﾌﾟ Sd43-jVDF)
2022/07/14(木) 23:23:30.65ID:BkEIWbQgd >>964
自分ならだけどこんな感じかと Mainのループは最大行数を取得してくれ _をスペースに置き換えてくれ
Sub_Main()
____Dim_i_As_Long
____For_i_=_1_To_5
________Dim_a_As_String
________a_=_Cells(i,_1).Value
________Dim_j_As_Long
________For_j_=_1_To_5
____________If_i_<>_j_Then
________________a_=_CutWord(a,_Cells(j,_1).Value)
____________End_If
________Next
________Cells(i,_2).Value_=_a
____Next
End_Sub
自分ならだけどこんな感じかと Mainのループは最大行数を取得してくれ _をスペースに置き換えてくれ
Sub_Main()
____Dim_i_As_Long
____For_i_=_1_To_5
________Dim_a_As_String
________a_=_Cells(i,_1).Value
________Dim_j_As_Long
________For_j_=_1_To_5
____________If_i_<>_j_Then
________________a_=_CutWord(a,_Cells(j,_1).Value)
____________End_If
________Next
________Cells(i,_2).Value_=_a
____Next
End_Sub
971デフォルトの名無しさん (ｽｯｯﾌﾟ Sd43-jVDF)
2022/07/14(木) 23:23:50.53ID:BkEIWbQgd Function_CutWord(a_As_String,_b_As_String)_As_String
____Dim_aa()_As_String
____aa_=_Split(a,_"_")
____Dim_bb()_As_String
____bb_=_Split(b,_"_")
____Dim_c_As_String
____c_=_""
____Dim_i_As_Long
____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
____________End_If
________Next
________If_j_>_UBound(bb)_Then
____________If_c_<>_""_Then
________________c_=_c_&_"_"
____________End_If
____________c_=_c_&_aa(i)
________End_If
____Next
____CutWord_=_c
End_Function
____Dim_aa()_As_String
____aa_=_Split(a,_"_")
____Dim_bb()_As_String
____bb_=_Split(b,_"_")
____Dim_c_As_String
____c_=_""
____Dim_i_As_Long
____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
____________End_If
________Next
________If_j_>_UBound(bb)_Then
____________If_c_<>_""_Then
________________c_=_c_&_"_"
____________End_If
____________c_=_c_&_aa(i)
________End_If
____Next
____CutWord_=_c
End_Function
972デフォルトの名無しさん (ﾜｯﾁｮｲ fdce-TkQT)
2022/07/14(木) 23:43:51.22ID:qWN4wD1T0973デフォルトの名無しさん (ﾜｯﾁｮｲ cbda-VQN5)
2022/07/14(木) 23:52:28.92ID:fadaSACN0 気持ちわりぃなそのコード
974デフォルトの名無しさん (ｱｳｱｳｳｰ Sa09-/dRU)
2022/07/15(金) 00:00:11.50ID:9RgIX2Zba975デフォルトの名無しさん (ｱｳｱｳｳｰ Sa09-MhTr)
2022/07/15(金) 00:30:48.57ID:1ECLhEg6a なんでスペースがアンダーバーなんだとは思うな
俺も見た目が受け付けなかったわ
俺も見た目が受け付けなかったわ
976デフォルトの名無しさん (ｽﾌﾟｯｯ Sd43-iSZE)
2022/07/15(金) 00:48:33.55ID:kd+ZBNkRd いや、そもそも自作自演だろ
977デフォルトの名無しさん (ﾜｯﾁｮｲ fdce-TkQT)
2022/07/15(金) 01:18:26.31ID:mFCZ39Ni0 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
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
978964 (ｽｯｯﾌﾟ Sd43-CglE)
2022/07/15(金) 02:31:06.28ID:bSLom3XEd 早速ご回答いただいた皆様、ありがとうございました！
ほぼ思い通りの結果を得ることができました。
ちなみにですが、
例えば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
度々申し訳ございませんが、よろしくお願いいたします。
ほぼ思い通りの結果を得ることができました。
ちなみにですが、
例えば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
度々申し訳ございませんが、よろしくお願いいたします。
979デフォルトの名無しさん (ﾜﾝﾐﾝｸﾞｸ MMa3-p0Nn)
2022/07/15(金) 02:36:26.14ID:WFW52ORLM いつものあいつだぞ
980デフォルトの名無しさん (ﾜｯﾁｮｲ fdce-TkQT)
2022/07/15(金) 06:01:47.46ID:mFCZ39Ni0 最小限の定義が不明
981デフォルトの名無しさん (ｽﾌｯ Sd43-TkQT)
2022/07/15(金) 07:03:30.04ID:ymO8mssad 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
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
982デフォルトの名無しさん (ｽｯﾌﾟﾌﾟ Sd43-jVDF)
2022/07/15(金) 07:30:27.66ID:KClfAjojd 俺のコードをいじってくれてうれしいが
Valueとったり改行いじったりしてるだけで行数減らしてるだけなんて結局マイルールのこだわりを主張してるだけなんだよな
こんな方法あるぜってのが見たいわ
>>978
6が「DOG」になる最小数という意味が不明
先頭の単語を返すだけならCutWordの最後でaとcが同じ値になったらaa(LBound(aa))を返すようにすればいいのでは
Valueとったり改行いじったりしてるだけで行数減らしてるだけなんて結局マイルールのこだわりを主張してるだけなんだよな
こんな方法あるぜってのが見たいわ
>>978
6が「DOG」になる最小数という意味が不明
先頭の単語を返すだけならCutWordの最後でaとcが同じ値になったらaa(LBound(aa))を返すようにすればいいのでは
983デフォルトの名無しさん (ｱｳｱｳｳｰ Sa09-/dRU)
2022/07/15(金) 07:47:41.51ID:9RgIX2Zba value取るのは改悪で草
984デフォルトの名無しさん (ｱｳｱｳｳｰ Sa09-DHlW)
2022/07/15(金) 08:08:12.42ID:DqNyEc18a >>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
複数回現れる単語を削除すればいいのか？
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
985デフォルトの名無しさん (ｱｳｱｳｳｰ Sa09-DHlW)
2022/07/15(金) 08:10:06.84ID:DqNyEc18a >>973
気持ち悪いとは思わないけどちょっと非効率かなとは思う
気持ち悪いとは思わないけどちょっと非効率かなとは思う
986デフォルトの名無しさん (ﾜｯﾁｮｲ cbda-VQN5)
2022/07/15(金) 08:49:49.31ID:pxeFAKZo0 そのコードカッケェ！
987デフォルトの名無しさん (ｽﾌｯ Sd43-TkQT)
2022/07/15(金) 09:42:45.28ID:D6klNH8hd 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
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
988デフォルトの名無しさん (ｱｳｱｳｳｰ Sa09-jVDF)
2022/07/15(金) 09:47:20.06ID:kfkt8EAfa 効率どうこう言う前に重複した単語がでるような関数はどうかと思うのｗ
989デフォルトの名無しさん (ｽﾌﾟｯｯ Sd43-iSZE)
2022/07/15(金) 13:22:47.81ID:kd+ZBNkRd ここでRuby馬鹿がRubyではこうなるとか書くのは見えている
990デフォルトの名無しさん (ﾜｯﾁｮｲ 4bda-TkQT)
2022/07/15(金) 19:00:37.71ID:f/pTHFXb0 オレンジ色のオレンジはどうなの？
991デフォルトの名無しさん (ﾜｯﾁｮｲ cbda-VQN5)
2022/07/15(金) 19:14:37.65ID:pxeFAKZo0 どんなに良コード書いても難癖付けられるのがこのスレ
992デフォルトの名無しさん (ﾜｯﾁｮｲ 05da-k1yI)
2022/07/16(土) 02:37:29.28ID:hVvvoOFI0 userformをshowした直後にunloadするとexcelが落ちるのは何とかならんかのぉ
hideじゃだめなんじゃunloadじゃないと
hideじゃだめなんじゃunloadじゃないと
993デフォルトの名無しさん (ﾜｯﾁｮｲ 9d5f-GsVe)
2022/07/16(土) 07:52:34.81ID:1SMMBEmo0 UserForm1.Show vbModeless
Unload UserForm1
って意味なら、別に落ちなかったけど
Unload UserForm1
って意味なら、別に落ちなかったけど
994デフォルトの名無しさん (ﾜｯﾁｮｲ 5a42-PUxa)
2022/07/16(土) 08:52:29.38ID:eHBMNsDF0 逆になんでhideじゃダメなの
995デフォルトの名無しさん (ﾜｯﾁｮｲ 912f-cIkS)
2022/07/16(土) 13:26:34.40ID:NLVpHfZz0 とりあえずEXCELが落ちるっていうコードと環境出せ
話はそれからだ
話はそれからだ
996デフォルトの名無しさん (ﾜｯﾁｮｲ 762c-lpz1)
2022/07/16(土) 18:00:44.38ID:2WLM14wy0 >>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
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
997デフォルトの名無しさん (ｱｳｱｳｳｰ Sa39-eHP4)
2022/07/16(土) 19:45:04.74ID:vYu+PcKIa >>996
廃止決定した言語じゃん
廃止決定した言語じゃん
998デフォルトの名無しさん (ﾜｯﾁｮｲ 5ada-XFSu)
2022/07/17(日) 00:22:00.69ID:lEW2LcQY0 あんたら色んな言語を習得していてエリートなんだな？
５ちゃんねるなんかにいてもったいねーわ
５ちゃんねるなんかにいてもったいねーわ
999デフォルトの名無しさん (ﾜｯﾁｮｲ 05da-k1yI)
2022/07/17(日) 02:44:22.32ID:rPHWMq+g01000デフォルトの名無しさん (ﾜｯﾁｮｲ 5a63-4HbS)
2022/07/17(日) 04:50:23.78ID:fLi6s9i70 こいつの書くコード、rubyとしてもクソコードなのがほんとひどい
10011001
Over 1000Thread このスレッドは１０００を超えました。
新しいスレッドを立ててください。
life time: 77日 2時間 26分 42秒
新しいスレッドを立ててください。
life time: 77日 2時間 26分 42秒
レス数が1000を超えています。これ以上書き込みはできません。
ニュース
- バリ島で男子生徒ら集団万引きか、防犯カメラ映像が拡散 京都の大谷中学・高校が「窃盗行為」謝罪★5 [七波羅探題★]
- 【速報】 米トランプ政権声明 「中国が台湾を奪おうとする、いかなる試みも阻止する」 中国「レッドラインだ」 ★2 [お断り★]
- 元プロ野球選手・堂上隼人（43）を20代女性2人へのわいせつ未遂容疑で8回目の逮捕…これまでの被害者は10代・20代の女性11人に [Anonymous★]
- 「残業キャンセル界隈」若者が増加？「職務放棄」との批判も…“定時退社の権利”どこまで通用するか [七波羅探題★]
- 【高校野球】なぜ『7回制』は反対多数でも止まらないか… 高野連が「全員の命」守るために貫く伝統より改革の姿勢 [冬月記者★]
- 体調不良で番組欠席続く山里亮太「この度は申し訳ございません」 [ひかり★]
- ヤフコメ民の8割「お米券とか意味ねえよ」どうして… [402859164]
- 【高市悲報】中国軍「公海で空母の発着訓練するって事前通告したのになんで自衛隊機は急接近してきたんだ…？」中国軍困惑 [931948549]
- 【高市悲報】自衛隊「実は事前に現場海域で中国軍から空母での発着訓練をすると通告がありました」え…？😨😨 [931948549]
- 【高市速報】中国「このままだと日本が先制攻撃してくる」 [583597859]
- ケンモメンが多分一番読んでる小説って普通にこれだよな [126644339]
- 【悲報】Vtuberさん、大炎上時代に突入する