Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
11 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【82343】セル内重複文字削除 マクロ勉強中です。。 24/8/18(日) 18:17 質問[未読]
【82344】Re:セル内重複文字削除 マナ 24/8/18(日) 20:00 発言[未読]
【82345】Re:セル内重複文字削除 マクロ勉強中です。。 24/8/18(日) 22:22 回答[未読]
【82346】Re:セル内重複文字削除 マナ 24/8/18(日) 23:08 発言[未読]
【82347】Re:セル内重複文字削除 マクロ勉強中です。。 24/8/18(日) 23:21 回答[未読]
【82348】Re:セル内重複文字削除 マナ 24/8/18(日) 23:34 発言[未読]
【82349】Re:セル内重複文字削除 マクロ勉強中です。。 24/8/19(月) 6:54 回答[未読]
【82350】Re:セル内重複文字削除 マナ 24/8/19(月) 7:19 発言[未読]
【82351】Re:セル内重複文字削除 マクロ勉強中です。。 24/8/19(月) 18:47 回答[未読]
【82352】Re:セル内重複文字削除 マナ 24/8/19(月) 22:05 発言[未読]
【82353】Re:セル内重複文字削除 マクロ勉強中です。。 24/8/20(火) 12:55 回答[未読]
【82354】Re:セル内重複文字削除 マナ 24/8/20(火) 19:49 発言[未読]
【82355】Re:セル内重複文字削除 マクロ勉強中です。。 24/8/21(水) 20:18 お礼[未読]
【82343】セル内重複文字削除
質問  マクロ勉強中です。。  - 24/8/18(日) 18:17 -
引用なし
パスワード
   素人なので、至らない点あればすみません。


選択したセル内に含まれる、重複した文字を、１文字のみ残して
その他の重複文字を削除する方法を教えていただきたいのです。

例）
うさぎ　ねこ　いぬ　　（←これで１セル）
いぬ　とり　さる　　（←これで１セル）
いるか　さかな　ハムスター　　（←これで１セル）
うさぎ　ハムスター　　（←これで１セル）
カエル　いぬ　パンダ　　（←これで１セル）

↓実行後

例）
うさぎ　ねこ　いぬ　　（←これで１セル）
とり　さる　　（←これで１セル）
いるか　さかな　ハムスター　　（←これで１セル）
カエル　パンダ　　（←これで１セル）


うさぎからパンダまでの５行✖️５セルのを選択した状態で、マクロを実行すると、
例の重複した文字の、うさぎ、いぬ、ハムスター　の、文字それぞれ一つを残して
その他は削除される。といった感じのコードは作れますでしょうか？

また、削除後にセル内に文字が無くなった場合は、上の行に繰り越したいです。

（※例で挙げた動物は、実際の消したい文字とは異なります）
【82344】Re:セル内重複文字削除
発言  マナ  - 24/8/18(日) 20:00 -
引用なし
パスワード
   ▼マクロ勉強中です。。 さん：

Sub test()
　　Dim d As Object, a1 As Object, a2 As Object
　　Dim r As Range, c As Range
　　Dim e
　　
　　If TypeName(Selection) <> "Range" Then Exit Sub
　　Set r = Selection
　　If r.Columns.Count > 1 Then Exit Sub
　　If WorksheetFunction.CountA(r) = 0 Then Exit Sub
　　r.Columns(2).ClearContents
　　
　　Set d = CreateObject("scripting.dictionary")
　　Set a1 = CreateObject("system.collections.arraylist")
　　Set a2 = CreateObject("system.collections.arraylist")
　　
　　For Each c In r
　　　　For Each e In Split(c.Value, "　")
　　　　　　If Not d.exists(e) Then
　　　　　　　　d(e) = True
　　　　　　　　a1.Add e
　　　　　　End If
　　　　Next
　　　　If a1.Count > 0 Then
　　　　　　a2.Add Join(a1.toarray, "　")
　　　　　　a1.Clear
　　　　End If
　　Next
　　
　　r(1, 2).Resize(a2.Count).Value = WorksheetFunction.Transpose(a2.toarray)
　　
End Sub
【82345】Re:セル内重複文字削除
回答  マクロ勉強中です。。  - 24/8/18(日) 22:22 -
引用なし
パスワード
   ▼マナ さん：
早速ありがとうございます。

実行してみたのですが、

このコンポーネントのライセンス情報が見つかりません。デザイン環境でこの機能を使うために必要なライセンスがありません。

と出てしまいました。。
【82346】Re:セル内重複文字削除
発言  マナ  - 24/8/18(日) 23:08 -
引用なし
パスワード
   ▼マクロ勉強中です。。 さん：

Sub test2()
　　Dim d As Object, d2 As Object, d3 As Object
　　Dim r As Range, c As Range
　　Dim e
　　
　　If TypeName(Selection) <> "Range" Then Exit Sub
　　Set r = Selection
　　If r.Columns.Count > 1 Then Exit Sub
　　If WorksheetFunction.CountA(r) = 0 Then Exit Sub
　　r.Columns(2).ClearContents
　　
　　Set d = CreateObject("scripting.dictionary")
　　Set d2 = CreateObject("scripting.dictionary")
　　Set d3 = CreateObject("scripting.dictionary")
　　
　　For Each c In r
　　　　For Each e In Split(c.Value, "　")
　　　　　　If Not d.exists(e) Then
　　　　　　　　d(e) = True
　　　　　　　　d2(e) = True
　　　　　　End If
　　　　Next
　　　　If d2.Count > 0 Then
　　　　　　d3(d3.Count) = Join(d2.keys, "　")
　　　　　　d2.RemoveAll
　　　　End If
　　Next
　　
　　r(1, 2).Resize(d3.Count).Value = WorksheetFunction.Transpose(d3.items)
　　
End Sub
【82347】Re:セル内重複文字削除
回答  マクロ勉強中です。。  - 24/8/18(日) 23:21 -
引用なし
パスワード
   ▼マナ さん：
素人過ぎて原因がわからず申し訳ないのですが、

このコンポーネントのライセンス情報が見つかりません。
デザイン環境でこの機能を使うために必要なライセンスがありません。

と出てしまいます。。。
【82348】Re:セル内重複文字削除
発言  マナ  - 24/8/18(日) 23:34 -
引用なし
パスワード
   ▼マクロ勉強中です。。 さん：
>
どの行でエラーになるのでしょうか？
【82349】Re:セル内重複文字削除
回答  マクロ勉強中です。。  - 24/8/19(月) 6:54 -
引用なし
パスワード
   ▼マナ さん：
>どの行でエラーになるのでしょうか？


確認の仕方が間違っているのかもしれませんが、
どの行の赤字になっているわけでもなく、エラー箇所がわかりません。
【82350】Re:セル内重複文字削除
発言  マナ  - 24/8/19(月) 7:19 -
引用なし
パスワード
   ▼マクロ勉強中です。。 さん：

これはエラーになりますか。

Sub test3()
　　Dim d As Object
　　Set d = CreateObject("scripting.dictionary")
End Sub

　Sub test4()
　　MsgBox "test"
End Sub
【82351】Re:セル内重複文字削除
回答  マクロ勉強中です。。  - 24/8/19(月) 18:47 -
引用なし
パスワード
   ▼マナ さん：
こちらはエラーにはなりませんでした。
【82352】Re:セル内重複文字削除
発言  マナ  - 24/8/19(月) 22:05 -
引用なし
パスワード
   ▼マクロ勉強中です。。 さん：

>こちらはエラーにはなりませんでした。

であれば、test2をステップ実行（F8)で、
どの行でエラーが発生するのか確認してください。
【82353】Re:セル内重複文字削除
回答  マクロ勉強中です。。  - 24/8/20(火) 12:55 -
引用なし
パスワード
   ▼マナ さん：

最近MacBookにPCを変えたのですが、
WindowsのPCで試してみたところ、エラー表示なく動作はしたのですが、
重複している文字が消えずに、選択したセルの右横のセルに入力されている文字が消えてしまいました。
【82354】Re:セル内重複文字削除
発言  マナ  - 24/8/20(火) 19:49 -
引用なし
パスワード
   ▼マクロ勉強中です。。 さん：

Sub test5()
　　Dim r As Range, c As Range
　　Dim v() As String, e
　　Dim s1 As String, s2 As String, s3 As String
　　Dim n As Long
　　
　　If TypeName(Selection) <> "Range" Then Exit Sub
　　Set r = Selection
　　If r.Columns.Count > 1 Then Exit Sub
　　If WorksheetFunction.CountA(r) = 0 Then Exit Sub
　　
　　ReDim v(1 To r.Count, 1 To 1)
　　
　　For Each c In r
　　　　For Each e In Split(c.Value, "　")
　　　　　　s2 = "　" & e & "　"
　　　　　　If InStr(s1, s2) = 0 Then
　　　　　　　　s1 = s1 & s2
　　　　　　　　s3 = s3 & "　" & e
　　　　　　End If
　　　　Next
　　　　If Len(s3) > 0 Then
　　　　　　n = n + 1
　　　　　　v(n, 1) = Mid(s3, 2)
　　　　　　s3 = ""
　　　　End If
　　Next

　　r.Value = v
　　
End Sub
【82355】Re:セル内重複文字削除
お礼  マクロ勉強中です。。  - 24/8/21(水) 20:18 -
引用なし
パスワード
   ▼マナ さん：

正常に動作致しました。
長々とお付き合いいただき、ありがとうございました！
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
11 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free