Excel VBA質問箱 IV

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

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


1680 / 13645 ツリー ←次へ | 前へ→

【72658】<を含む言葉を抜き出す おにこ 12/8/31(金) 16:22 質問[未読]
【72661】Re:<を含む言葉を抜き出す ドカ 12/8/31(金) 17:32 回答[未読]
【72662】Re:<を含む言葉を抜き出す ドカ 12/8/31(金) 17:41 発言[未読]
【72665】Re:<を含む言葉を抜き出す ドカ 12/8/31(金) 19:40 回答[未読]
【72668】Re:<を含む言葉を抜き出す UO3 12/8/31(金) 23:12 発言[未読]
【72677】Re:<を含む言葉を抜き出す おにこ 12/9/3(月) 9:41 お礼[未読]
【72663】Re:<を含む言葉を抜き出す kanabun 12/8/31(金) 19:21 発言[未読]
【72667】Re:<を含む言葉を抜き出す kanabun 12/8/31(金) 19:58 発言[未読]
【72669】Re:<を含む言葉を抜き出す Yuki 12/9/1(土) 11:43 発言[未読]
【72673】Re:<を含む言葉を抜き出す kanabun 12/9/1(土) 23:57 質問[未読]
【72674】Re:<を含む言葉を抜き出す Yuki 12/9/2(日) 8:54 発言[未読]
【72678】Re:<を含む言葉を抜き出す おにこ 12/9/3(月) 9:42 お礼[未読]
【72676】Re:<を含む言葉を抜き出す kanabun 12/9/2(日) 21:04 発言[未読]
【72679】Re:<を含む言葉を抜き出す おにこ 12/9/3(月) 9:44 お礼[未読]

【72658】<を含む言葉を抜き出す
質問  おにこ  - 12/8/31(金) 16:22 -

引用なし
パスワード
   列AAに

たぬき<みどり>、きつね
きつね、たぬき
たぬき<赤>、きつね<茶色>
たぬき、きつね<みどり>

とあります。

「<>」を含む言葉がある場合、AH列に「<>」を含む言葉を移動させたいです。

たぬき<みどり>、きつね⇒AA列:きつね AH列:たぬき<みどり>
きつね、たぬき⇒AA列:きつね、たぬき
たぬき<赤>、きつね<茶色>⇒AA列:(空欄) AH列:たぬき<赤>、きつね<茶色>
たぬき、きつね<みどり>⇒AA列:たぬき  AH列:きつね<みどり>

にしたいです。

どのようにVBAを作成したらよいのでしょうか

【72661】Re:<を含む言葉を抜き出す
回答  ドカ  - 12/8/31(金) 17:32 -

引用なし
パスワード
   ▼おにこ さん:

こんなことでしょうか?
上から順にマクロを実施してください。


Sub データ分解()

  Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="、", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End Sub


Sub 探す()


For n = 1 To 10
p = 0
p1 = 0
  
  For i = 1 To 10
    If Cells(n, i) <> "" Then
      If Cells(n, i).Value Like "*<*" Then
        Cells(n, 33 + p) = Cells(n, i)
        p = p + 1
      Else
        Cells(n, 27 + p1) = Cells(n, i)
        p1 = p1 + 1
      End If
    Else
      Exit For
    End If
  Next
Next
End Sub


Sub 結合()
For n = 1 To 10
  For i = 1 To 5
    If Cells(n, 27 + i) <> "" Then
      Cells(n, 27) = Cells(n, 27) & "、" & Cells(n, 27 + i)
      Cells(n, 27 + i) = ""
    End If
  Next
Next

For n = 1 To 10
  For i = 1 To 5
    If Cells(n, 33 + i) <> "" Then
      Cells(n, 33) = Cells(n, 33) & "、" & Cells(n, 33 + i)
      Cells(n, 33 + i) = ""
    End If
  Next
Next
End Sub

【72662】Re:<を含む言葉を抜き出す
発言  ドカ  - 12/8/31(金) 17:41 -

引用なし
パスワード
   >▼おにこ さん:

よく読まずに、A列にあるとして、データを移動するマクロを書いてしまいました。
後はご自分で対応できるならよろしくお願いします。

【72663】Re:<を含む言葉を抜き出す
発言  kanabun  - 12/8/31(金) 19:21 -

引用なし
パスワード
   ▼おにこ さん:

語と語の区切りは「、」ですか?

だとして、

(元)  AA列
たぬき<みどり>、きつね
きつね、たぬき
たぬき<赤>、きつね<茶色>
たぬき、きつね<みどり>

(移動後)
  AA列             AH列
きつね             たぬき<みどり>
きつね、たぬき
                たぬき<赤>、きつね<茶色>
たぬき             きつね<みどり>

となればいいのですか?

Sub Try2()
  Dim r As Range, c As Range
  Dim ss As String, aa, ah
  Dim i As Long
  Dim List1 As Object
  Dim List2 As Object
  Set List1 = CreateObject("Forms.Combobox.1")
  Set List2 = CreateObject("Forms.Combobox.1")
  
  For Each c In Range("AA1", Cells(Rows.Count, "AA").End(xlUp))
    ss = c.Value
    If InStr(ss, "<") > 0 Then
      aa = Split(ss, "、") 'セルの文字列を「、」で分割
      List1.List = aa
      List2.List = aa
      With List1
        For i = .ListCount - 1 To 0 Step -1
          If .List(i) Like "*<*>*" Then
            .RemoveItem i
          Else
            List2.RemoveItem i
          End If
        Next
      End With
      aa = ""
      ah = ""
      Select Case List1.ListCount
       Case Is = 1: aa = List1.List(0)
       Case Is > 1: aa = Join(Application.Transpose(List1.List), "、")
      End Select
      Select Case List2.ListCount
       Case Is = 1: ah = List2.List(0)
       Case Is > 1: ah = Join(Application.Transpose(List2.List), "、")
      End Select
      c.Value = aa
      c.Offset(, 7).Value = ah
    End If
  Next
    
End Sub

【72665】Re:<を含む言葉を抜き出す
回答  ドカ  - 12/8/31(金) 19:40 -

引用なし
パスワード
   >>▼おにこ さん 
また時間ができたので、やっておきました。

私のマクロは、他の皆さんと違って、基本的なことさえ知っていれば、作れるコードで書いています。マクロの記録などもそのまま使っています。
それでも動くことがVBAの最大のメリットではないのかな?
ただし、処理速度が遅くて使いものにならない時は、別途スマートなコードが必要です。

Sub Macro4()
  シート名 = ActiveSheet.Name
  ActiveSheet.Copy Before:=Sheets(1)

  シート名1 = ActiveSheet.Name
  Columns("A:Z").Select
  Selection.Delete Shift:=xlToLeft
  

'データ分解()
  
  Columns("A:A").Select
  Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="、", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True


' 探す()


For n = 1 To 10
p = 0
p1 = 0
 
  For i = 1 To 10
    If Cells(n, i) <> "" Then
      If Cells(n, i).Value Like "*<*" Then
        Cells(n, 33 + p) = Cells(n, i)
        p = p + 1
      Else
        Cells(n, 27 + p1) = Cells(n, i)
        p1 = p1 + 1
      End If
    Else
      Exit For
    End If
  Next
Next


' 結合()
For n = 1 To 10
  For i = 1 To 5
    If Cells(n, 27 + i) <> "" Then
      Cells(n, 27) = Cells(n, 27) & "、" & Cells(n, 27 + i)
      Cells(n, 27 + i) = ""
    End If
  Next
Next

For n = 1 To 10
  For i = 1 To 5
    If Cells(n, 33 + i) <> "" Then
      Cells(n, 33) = Cells(n, 33) & "、" & Cells(n, 33 + i)
      Cells(n, 33 + i) = ""
    End If
  Next
Next

' 貼り付け()
'

  Columns("AA:AA").Select
  Selection.Copy

  Worksheets(シート名).Select

  Columns("AA:AA").Select
  ActiveSheet.Paste

  Worksheets(シート名1).Select
  Columns("AG:AG").Select
  Selection.Copy

  Worksheets(シート名).Select

  Columns("AG:AG").Select
  ActiveSheet.Paste

  Worksheets(シート名1).Delete
End Sub

【72667】Re:<を含む言葉を抜き出す
発言  kanabun  - 12/8/31(金) 19:58 -

引用なし
パスワード
   >▼おにこ さん:
>
>語と語の区切りは「、」
>だとして、
>
>(元)  AA列
>たぬき<みどり>、きつね
>
>(移動後)
>  AA列             AH列
>きつね             たぬき<みどり>

>となればいいのですか?
>

上のコードでやっていることを図で説明します。

AA列を1行づつ順に処理していきます。
  セルの文字列中に「<」があったときだけ、移動処理をします。
>    If InStr(ss, "<") > 0 Then

>      aa = Split(ss, "、") 'セルの文字列を「、」で分割
分割したリストを2つのComboBoxのリストにセットします。
  (このComboBoxは 見えません)
>      List1.List = aa
>      List2.List = aa
     List1           List2   
   ┌─────────┐   ┌─────────┐
   │たぬき<みどり> │   │たぬき<みどり> │
   │きつね      │   │きつね      │
   │         │   │         │
   │         │   │         │
   │         │   │         │
   │         │   │         │
   └─────────┘   └─────────┘

>      With List1
   このリストを下から調べていきます。
>        For i = .ListCount - 1 To 0 Step -1
      もし対象リストアイテムに「<*>」が含まれていたら
>          If .List(i) Like "*<*>*" Then
        List1からそのアイテムを削除します
>            .RemoveItem i
>          Else
        含まれていなければ、List2のその行を削除します
>            List2.RemoveItem i
>          End If
>        Next
>      End With

この処理がおわると、2つのリストは以下のようになっています
     List1           List2   
   ┌─────────┐   ┌─────────┐
   │きつね      │   │たぬき<みどり> │
   │          │   │         │
   │         │   │         │
   │         │   │         │
   │         │   │         │
   │         │   │         │
   └─────────┘   └─────────┘
それぞれのリストを(アイテムが複数あれば「、」でJoinして)
AA列とAH列に貼り付けます。
>      c.Value = aa
>      c.Offset(, 7).Value = ah

【72668】Re:<を含む言葉を抜き出す
発言  UO3  - 12/8/31(金) 23:12 -

引用なし
パスワード
   ▼ドカ さん:

こんばんは

>私のマクロは、他の皆さんと違って、基本的なことさえ知っていれば、作れるコードで書いています。マクロの記録などもそのまま使っています。
>それでも動くことがVBAの最大のメリットではないのかな?

ドカさんが回答されるコードを拝見していて、このドカさんの方針といいますか
スタンスは理解していますし、質問者さんは初心者がおおいので、できるだけ
わかりやすいコードにして回答しておられることについては、一理あると考えています。

ただ、やはり、質問者さんは回答者からの回答コードを「模範」として、その後、書いていくコードに
反映していくんだろうなと思います。

そういう意味では、わかりやすいコードというところは異論はありませんが
やはり、Select/Selection や シートをSelect して アクティブシートを前提にしたセル記述 等々は
やはり、質問者さんには、一日も早く、そのクセから抜けていただきたいと思っています。
動きが無駄と言うことより、そのことが、往々にしてバグを引き起こす要因になるからです。
(ドカさんのコードではないのですが、セルをSelectしてActiveCellに対して処理をするのもバグの要因になったりしますね)


また、セルを扱う場合はプロパティも明示するように、質問者さんには常々アドバイスをしております。
このことも、重要なことだと、そう思っています。

【72669】Re:<を含む言葉を抜き出す
発言  Yuki  - 12/9/1(土) 11:43 -

引用なし
パスワード
   ▼おにこ さん:
こんにちは。

こんな感じで

Sub TEST()
  Dim i    As Long
  Dim j    As Long
  Dim x    As Long
  Dim y    As Long
  Dim v    As Variant
  Dim v1   As Variant
  Dim S1()  As String
  Dim S2()  As String
  
  v = Range("AA1").CurrentRegion.Resize(, 1).Value
  For i = 1 To UBound(v)
    Erase S1
    Erase S2
    x = 0
    y = 0
    v1 = Split(v(i, 1), "、", , vbTextCompare)
    For j = 0 To UBound(v1)
      If InStr(1, v1(j), "<", vbTextCompare) > 0 And _
        InStr(1, v1(j), ">", vbTextCompare) > 0 Then
        ReDim Preserve S1(x)
        S1(x) = v1(j)
        x = x + 1
      Else
        ReDim Preserve S2(y)
        S2(y) = v1(j)
        y = y + 1
      End If
    Next
    Cells(i, 27).Value = Join(S2, "、")
    Cells(i, 34).Value = Join(S1, "、")
  Next
End Sub

【72673】Re:<を含む言葉を抜き出す
質問  kanabun  - 12/9/1(土) 23:57 -

引用なし
パスワード
   ▼Yuki さん:

Yuki さんのことですから、↓茶々ですけどゆるしてね

>こんな感じで
>  v = Range("AA1").CurrentRegion.Resize(, 1).Value

A列〜 Z列までデータがあったばあいは、変数v にどの列の
値が入るのでしょうか?

【72674】Re:<を含む言葉を抜き出す
発言  Yuki  - 12/9/2(日) 8:54 -

引用なし
パスワード
   ▼kanabun さん:
>
>>こんな感じで
>>  v = Range("AA1").CurrentRegion.Resize(, 1).Value
>
>A列〜 Z列までデータがあったばあいは、変数v にどの列の
>値が入るのでしょうか?

kanabunさん、どうもです。
最近CurentResionの件で能書きを書いたそのまんまですね。
えらい勘違いです。
v = Range("AA1").CurrentRegion,offset(,26).Resize(, 1).Value

Endプロパティで最終行を求めてでしょうか。

【72676】Re:<を含む言葉を抜き出す
発言  kanabun  - 12/9/2(日) 21:04 -

引用なし
パスワード
   ▼おにこ さん:

>「<>」を含む言葉がある場合、AH列に「<>」を含む言葉を移動させたいです。

参考まで、別法です

Sub Try3b()
  Dim r As Range, c As Range
  Dim ss As String, v, vv
  Dim aa() As String
  Dim k As Long
  Const z = "、"
  
  Set r = Range("AA1", Cells(Rows.Count, "AA").End(xlUp))
  For Each c In r
    ss = c.Value
    If ss Like "*<*>*" Then 'セル内に<*>があれば
      vv = Split(ss, z) '"、"でブロックに分割
      ReDim aa(1)
      For Each v In vv
         'このブロックは<*>があるか
        k = IIf(v Like "*<*>*", 1, 0)
        If Len(aa(k)) > 0 Then
          aa(k) = aa(k) & z & v
        Else
          aa(k) = v
        End If
      Next
      c.Value = aa(0)      '<*>の含まれないブロック
      c.Offset(, 7).Value = aa(1) '<*>の含まれるブロック
    End If
  Next
End Sub

【72677】Re:<を含む言葉を抜き出す
お礼  おにこ  - 12/9/3(月) 9:41 -

引用なし
パスワード
   ドカ さん

丁寧に回答していただきありがとうございます。
初心者なので、大変助かります。
ひとつずつ理解していきたいと思います。
本当にどうもありがとうございました。


▼ドカ さん:
>>>▼おにこ さん 
>また時間ができたので、やっておきました。
>
>私のマクロは、他の皆さんと違って、基本的なことさえ知っていれば、作れるコードで書いています。マクロの記録などもそのまま使っています。
>それでも動くことがVBAの最大のメリットではないのかな?
>ただし、処理速度が遅くて使いものにならない時は、別途スマートなコードが必要です。
>
>Sub Macro4()
>  シート名 = ActiveSheet.Name
>  ActiveSheet.Copy Before:=Sheets(1)
>
>  シート名1 = ActiveSheet.Name
>  Columns("A:Z").Select
>  Selection.Delete Shift:=xlToLeft
>  
>
>'データ分解()
>  
>  Columns("A:A").Select
>  Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
>    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
>    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
>    :="、", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
>
>
>' 探す()
>
>
>For n = 1 To 10
>p = 0
>p1 = 0
> 
>  For i = 1 To 10
>    If Cells(n, i) <> "" Then
>      If Cells(n, i).Value Like "*<*" Then
>        Cells(n, 33 + p) = Cells(n, i)
>        p = p + 1
>      Else
>        Cells(n, 27 + p1) = Cells(n, i)
>        p1 = p1 + 1
>      End If
>    Else
>      Exit For
>    End If
>  Next
>Next
>
>
>' 結合()
>For n = 1 To 10
>  For i = 1 To 5
>    If Cells(n, 27 + i) <> "" Then
>      Cells(n, 27) = Cells(n, 27) & "、" & Cells(n, 27 + i)
>      Cells(n, 27 + i) = ""
>    End If
>  Next
>Next
>
>For n = 1 To 10
>  For i = 1 To 5
>    If Cells(n, 33 + i) <> "" Then
>      Cells(n, 33) = Cells(n, 33) & "、" & Cells(n, 33 + i)
>      Cells(n, 33 + i) = ""
>    End If
>  Next
>Next
>
>' 貼り付け()
>'
>
>  Columns("AA:AA").Select
>  Selection.Copy
>
>  Worksheets(シート名).Select
>
>  Columns("AA:AA").Select
>  ActiveSheet.Paste
>
>  Worksheets(シート名1).Select
>  Columns("AG:AG").Select
>  Selection.Copy
>
>  Worksheets(シート名).Select
>
>  Columns("AG:AG").Select
>  ActiveSheet.Paste
>
>  Worksheets(シート名1).Delete
>End Sub

【72678】Re:<を含む言葉を抜き出す
お礼  おにこ  - 12/9/3(月) 9:42 -

引用なし
パスワード
   Yuki さん

丁寧に回答していただきありがとうございます。
初心者なので、大変助かります。
ひとつずつ理解していきたいと思います。
本当にどうもありがとうございました。


▼Yuki さん:
>▼kanabun さん:
>>
>>>こんな感じで
>>>  v = Range("AA1").CurrentRegion.Resize(, 1).Value
>>
>>A列〜 Z列までデータがあったばあいは、変数v にどの列の
>>値が入るのでしょうか?
>
>kanabunさん、どうもです。
>最近CurentResionの件で能書きを書いたそのまんまですね。
>えらい勘違いです。
>v = Range("AA1").CurrentRegion,offset(,26).Resize(, 1).Value
>か
>Endプロパティで最終行を求めてでしょうか。

【72679】Re:<を含む言葉を抜き出す
お礼  おにこ  - 12/9/3(月) 9:44 -

引用なし
パスワード
   ▼kanabun さん:

わかりやすく、丁寧に説明していただきありがとうございます。
印刷して、じっくり読んで勉強しようと思います。
本当に感謝しています。ありがとうございました。


>▼おにこ さん:
>
>>「<>」を含む言葉がある場合、AH列に「<>」を含む言葉を移動させたいです。
>
>参考まで、別法です
>
>Sub Try3b()
>  Dim r As Range, c As Range
>  Dim ss As String, v, vv
>  Dim aa() As String
>  Dim k As Long
>  Const z = "、"
>  
>  Set r = Range("AA1", Cells(Rows.Count, "AA").End(xlUp))
>  For Each c In r
>    ss = c.Value
>    If ss Like "*<*>*" Then 'セル内に<*>があれば
>      vv = Split(ss, z) '"、"でブロックに分割
>      ReDim aa(1)
>      For Each v In vv
>         'このブロックは<*>があるか
>        k = IIf(v Like "*<*>*", 1, 0)
>        If Len(aa(k)) > 0 Then
>          aa(k) = aa(k) & z & v
>        Else
>          aa(k) = v
>        End If
>      Next
>      c.Value = aa(0)      '<*>の含まれないブロック
>      c.Offset(, 7).Value = aa(1) '<*>の含まれるブロック
>    End If
>  Next
>End Sub

1680 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free