Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(指定なし : 指定なし)
文字の変換の際に文字の部分変更を維持する方法
投稿日時: 23/11/28 11:33:43
投稿者: O.M

ユーザーフォームを起動し、変換する条件を選んで洗濯セルの文字の変換をしているのですが、
セル内の文字の部分的に変更している文字色や太字指定やフォントなどが消えてしまいます。
消えないように変換するにはどのようにすればよいでしょうか?
 
全角半角変換

Private Sub CommandButton1_Click()
  Dim TargetCell As Range
  Dim Text As String, ChangeText As String, conversion As Variant
  conversion = vbNarrow
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Text = TargetCell.Value
    '数字変換
    If CheckBox1.Value = True Then
      ChangeText = "[0-9]"
      ZenHanConvert Text, ChangeText, conversion
    End If
    '英字変換
    If CheckBox2.Value = True Then
      ChangeText = "[A-Z,a-z]"
      ZenHanConvert Text, ChangeText, conversion
    End If
    'カタカナ変換
    If CheckBox3.Value = True Then
      ChangeText = "[ア-ン]"
      ZenHanConvert Text, ChangeText, conversion
    End If
    '記号変換
    If CheckBox4.Value = True Then
      ChangeText = "[!0-9,A-Z,a-z,ア-ン]"
      ZenHanConvert Text, ChangeText, conversion
    End If
    If TargetCell.Value <> Text Then
      TargetCell.Value = Text
    End If
  Next
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

'文字変換
Public Sub ZenHanConvert(Text As String, ChangeText As String, conversion As Variant)
  Dim i As Long, buf As String
  For i = 1 To Len(Text)
      If Mid(Text, i, 1) Like ChangeText Then
          buf = buf & StrConv(Mid(Text, i, 1), conversion)
      Else
          buf = buf & Mid(Text, i, 1)
      End If
  Next i
  Text = buf
End Sub

 
 
'大文字小文字変換
Private Sub CommandButton3_Click()
  Dim conversion As Variant, Text As String
  Dim TargetCell As Range
  '単語先頭を大文字
  If OptionButton1.Value = True Then
    conversion = vbProperCase
  End If
  '大文字変換
  If OptionButton2.Value = True Then
    conversion = vbUpperCase
  End If
  '小文字変換
  If OptionButton3.Value = True Then
    conversion = vbLowerCase
  End If
  '変換
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Text = StrConv(TargetCell.Value, conversion)
    If TargetCell.Value <> Text Then
      TargetCell.Value = Text
    End If
  Next
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

 
'スペースの削除
Private Sub SpaceRun_Click()
  '変換
  Select Case True
    Case Space1.Value
      If Space2to1 = True Then Exit Sub
    Case Space2.Value
      If Space1to2 = True Then Exit Sub
    Case Space3.Value
      If LeftSpaceDel = True Then Exit Sub
    Case Space4.Value
      If RightSpaceDel = True Then Exit Sub
    Case Space5.Value
      If LeftRightSpaceDel = True Then Exit Sub
    Case Space6.Value
      If SpaceDel = True Then Exit Sub
  End Select
End Sub

Public Function Space2to1() As Boolean
  Dim Text As String
  Dim TargetCell As Range
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Text = Replace(TargetCell.Value, "  ", " ", 1)
    If TargetCell.Value <> Text Then
      TargetCell.Value = Text
    End If
  Next
  Application.EnableEvents = True
  Application.ScreenUpdating = True
Exit Function
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Space2to1 = True
End Function

Public Function Space1to2() As Boolean
  Dim Text As String
  Dim TargetCell As Range
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Text = Replace(TargetCell.Value, " ", "  ", 1)
    If TargetCell.Value <> Text Then
      TargetCell.Value = Text
    End If
  Next
  Application.EnableEvents = True
  Application.ScreenUpdating = True
Exit Function
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Space1to2 = True
End Function

Public Function LeftSpaceDel() As Boolean
  Dim Text As String
  Dim TargetCell As Range
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Text = LTrim(TargetCell.Value)
    If TargetCell.Value <> Text Then
      TargetCell.Value = Text
    End If
  Next
  Application.EnableEvents = True
  Application.ScreenUpdating = True
Exit Function
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  LeftSpaceDel = True
End Function

Public Function RightSpaceDel() As Boolean
  Dim Text As String
  Dim TargetCell As Range
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Text = RTrim(TargetCell.Value)
    If TargetCell.Value <> Text Then
      TargetCell.Value = Text
    End If
  Next
  Application.EnableEvents = True
  Application.ScreenUpdating = True
Exit Function
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  RightSpaceDel = True
End Function

Public Function LeftRightSpaceDel() As Boolean
  Dim Text As String
  Dim TargetCell As Range
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Text = Trim(TargetCell.Value)
    If TargetCell.Value <> Text Then
      TargetCell.Value = Text
    End If
  Next
  Application.EnableEvents = True
  Application.ScreenUpdating = True
Exit Function
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  LeftRightSpaceDel = True
End Function

Public Function SpaceDel() As Boolean
  Dim Text As String
  Dim TargetCell As Range
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Text = Application.Trim(TargetCell.Value)
    If TargetCell.Value <> Text Then
      TargetCell.Value = Text
    End If
  Next
  Application.EnableEvents = True
  Application.ScreenUpdating = True
Exit Function
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  SpaceDel = True
End Function

[/code]

回答
投稿日時: 23/11/28 13:31:54
投稿者: simple

charactersを使って1文字ごとに置換していく方法があると思いますが、かなり遅いはずです。
また、置換により文字数が増えたりすると、後続の文字列の位置も変わってくるので、
収拾がつかなくなる恐れ(可能性)があります。
 
そこで。
セルの XMLスプレッドシート形式の値を取得して、
タグ以外の地の文字列だけを、正規表現を使って置換するとよいと思います。
置換後のXMLスプレッドシート形式の文字列を、再度書き戻せばよいと思います。
 
この方法であれば、セルのオブジェクトには一切触らずに、テキスト処理の範疇で
ものごとが終わります。
 
下記に、プロトタイプを示しますので、トライしてみてください。
この例では大文字化する例としていますが、
UCase(ss)の個所を、あなたが作成した文字列置換関数に置き換えればよいと思います。
 
’A1セルの文字ごとの書式を変更せずに、文字列を大文字化し、B1に書き込む例です

Sub main()
    Dim reg As Object
    Dim matches As Object
    Dim m As Object
    Dim c&, j&, p&, s$, ss$
    
    Set reg = CreateObject("VBScript.RegExp")
    
    '正規表現の指定
    With reg
        .Pattern = ">([^<>\s]+?)<"
        .Global = True
    End With
    
    s = [A1].Value(xlRangeValueXMLSpreadsheet) 'セルの XMLスプレッドシート形式の値を返す
    Set matches = reg.Execute(s)
    c = matches.Count
    
    For j = c To 1 Step -1
        Debug.Print matches(j - 1).FirstIndex, matches(j - 1).submatches(0)
        p = matches(j - 1).FirstIndex       'マッチ個所の位置(0オリジンであることに注意)
        ss = matches(j - 1).submatches(0)   'マッチした部分文字列
        s = Left(s, p + 1) & UCase(ss) & Mid(s, p + 2 + Len(ss))
    Next
    [B1].Value(xlRangeValueXMLSpreadsheet) = s
End Sub

投稿日時: 23/11/28 14:15:04
投稿者: O.M

ありがとうございます。
  
教えていただいたコードの意味がうまく理解できず、すぐには自分の作ったコードに落とし込んで試すことができなさそうです。
しばらく勉強させていただいてから結果もしくは分からない点の再質問を
このスレッドにさせていただきたいと思います。
※現状は全体的に分からず質問箇所が絞れない状態です。
  
  
  
ちなみに、質問後をさせていただいたとも色々調べて、
遅いとご指摘のあるcharactersで全角半角変換だけはできるようになった状態でした。
  
下記サイト様のコードを参考に
https://koukimra.com/archives/1595
  
以下のように訂正していました。
  

'全角→半角 条件設定
Private Sub CommandButton1_Click()
  Dim TargetCell As Range
  Dim rn As Range, ChangeText As String, conversion As Variant
  conversion = vbNarrow
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Set rn = TargetCell
    '数字変換
    If CheckBox1.Value = True Then
      ChangeText = "[0-9]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    '英字変換
    If CheckBox2.Value = True Then
      ChangeText = "[A-Z,a-z]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    'カタカナ変換
    If CheckBox3.Value = True Then
      ChangeText = "[ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    '記号変換
    If CheckBox4.Value = True Then
      ChangeText = "[!0-9,A-Z,a-z,ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
    End If
  Next
ErrHndl:
End Sub

'半角→全角 条件設定
Private Sub CommandButton2_Click()
  Dim rn As Range, ChangeText As String, conversion As Variant
  Dim TargetCell As Range
  conversion = vbWide
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
    Set rn = TargetCell
    '数字変換
    If CheckBox5.Value = True Then
      ChangeText = "[0-9]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    '英字変換
    If CheckBox6.Value = True Then
      ChangeText = "[A-Z,a-z]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    'カタカナ変換
    If CheckBox7.Value = True Then
      ChangeText = "[ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    '記号変換
    If CheckBox8.Value = True Then
      ChangeText = "[!0-9,A-Z,a-z,ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
    End If
  Next
ErrHndl:
End Sub

'全角半角変換
Public Function ZenHanConvert(rn As Range, ChangeText As String, conversion As Variant)
  Dim i As Long, j As Long
  '数式、文字列型以外の値は対象外
  If rn.HasFormula Then Exit Function
  If VarType(rn.Value) <> vbString Then Exit Function
  '文字の変換
  j = rn.Characters.Count
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For i = 1 To j
    With rn.Characters(i, 1)
      If .Text Like ChangeText Then
          .Text = StrConv(.Text, conversion)
      End If
    End With
  Next i
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Function

投稿日時: 23/11/28 15:02:29
投稿者: O.M

まだ意味は全くわかっていないのですが
変更したら対応できそうな場所に目星をつけてコードを書き換えてみたところ、
大文字変換と小文字変換は変換できました。
ありがとうございます。
 
文字列の各単語の先頭の文字を大文字に変換する場合がわからなかったのですが、
どのようにすればよいのでしょうか?
(StrconvのvbProperCaseのような変換)
 
splitで全角スペース及び半角スペースで区切って、
先頭の文字列のいちを割り出して、先頭の文字列位置には大文字変換、
それ以外は小文字変換…といった方法しか浮かびませんでした。
 

Private Sub CommandButton3_Click()
  Dim conversion As Variant, Text As String
  Dim TargetCell As Range
  '単語先頭を大文字
  If OptionButton1.Value = True Then
    conversion = vbProperCase
  End If
  '大文字変換
  If OptionButton2.Value = True Then
    conversion = vbUpperCase
  End If
  '小文字変換
  If OptionButton3.Value = True Then
    conversion = vbLowerCase
  End If
  '変換
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For Each TargetCell In Selection.Cells
     ProUpLowChange TargetCell, conversion
  Next
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

Private Function ProUpLowChange(TargetCell As Range, conversion As Variant)
    Dim reg As Object
    Dim matches As Object
    Dim m As Object
    Dim c&, j&, p&, s$, ss$
    
    Set reg = CreateObject("VBScript.RegExp")
    
    '正規表現の指定
    With reg
        .Pattern = ">([^<>\s]+?)<"
        .Global = True
    End With
    
    s = TargetCell.Value(xlRangeValueXMLSpreadsheet) 'セルの XMLスプレッドシート形式の値を返す
    Set matches = reg.Execute(s)
    c = matches.Count
    
    On Error GoTo ErrHndl
    For j = c To 1 Step -1
        Debug.Print matches(j - 1).FirstIndex, matches(j - 1).submatches(0)
        p = matches(j - 1).FirstIndex       'マッチ個所の位置(0オリジンであることに注意)
        ss = matches(j - 1).submatches(0)   'マッチした部分文字列
        Select Case conversion
          Case vbLowerCase
           '
          Case vbUpperCase
            s = Left(s, p + 1) & UCase(ss) & Mid(s, p + 2 + Len(ss))
          Case vbLowerCase
            s = Left(s, p + 1) & LCase(ss) & Mid(s, p + 2 + Len(ss))
        End Select
    Next
    TargetCell.Value(xlRangeValueXMLSpreadsheet) = s
ErrHndl:
End Function

投稿日時: 23/11/28 15:38:46
投稿者: O.M

教えていただいた下記コードで
 
’A1セルの文字ごとの書式を変更せずに、文字列を大文字化し、B1に書き込む例です

Sub main()
    Dim reg As Object
    Dim matches As Object
    Dim m As Object
    Dim c&, j&, p&, s$, ss$
    
    Set reg = CreateObject("VBScript.RegExp")
    
    '正規表現の指定
    With reg
        .Pattern = ">([^<>\s]+?)<"
        .Global = True
    End With
    
    s = [A1].Value(xlRangeValueXMLSpreadsheet) 'セルの XMLスプレッドシート形式の値を返す
    Set matches = reg.Execute(s)
    c = matches.Count
    
    For j = c To 1 Step -1
        Debug.Print matches(j - 1).FirstIndex, matches(j - 1).submatches(0)
        p = matches(j - 1).FirstIndex       'マッチ個所の位置(0オリジンであることに注意)
        ss = matches(j - 1).submatches(0)   'マッチした部分文字列
        s = Left(s, p + 1) & UCase(ss) & Mid(s, p + 2 + Len(ss))
    Next
    [B1].Value(xlRangeValueXMLSpreadsheet) = s
End Sub

 
 
A1セルに下記の文字を記載するとうまく変換できませんでした。
matches.Countが0担っているようなのですが理由が理解できておらず苦戦中です。
 
リモデルタイプ SH596BAYR(密結タンク 手洗なし/フタ固定あり) tcf5851AU(ウォシュレットアプリコットP AP2AF)

回答
投稿日時: 23/11/28 17:02:37
投稿者: simple

.Pattern = ">([^<>\s]+?)<"

.Pattern = ">([^<>\n]+?)<"
に変更してみてください。
 
なお、単語の途中で書式が変わっていたりすると、単語の途中で要素が分かれます。
したがって、各要素だけを見て、それが単語の始まりであるかを認識することはできませんし、
文頭であることの判断ができなかったりするなどの自然な制約があることは常識でご判断ください。
 
それは、1文字ずつだけ判定していくときに、文頭や単語の始まりが判定できないのと同じです。

投稿日時: 23/11/28 21:57:01
投稿者: O.M

変更指示いただいたコードで変換できました、ありがとうございます。
 
 
 
内容はよく理解できておらず、
変更箇所の目星をつけてコード改変して成功するまでいじりまくるという手法を取って
してしまっているのですが、
教えていただいたコードの配列(?)の文字列部分をいったん全てつなげて変換して、
分解して戻すという方法で、先頭の文字を大文字で変換もできました。
 
 
改変したコード

Sub main()
    Dim reg As Object
    Dim matches As Object
    Dim m As Object
    Dim c&, j&, p&, s$, ss$
    
    Dim udtary As ary
    
    
    Set reg = CreateObject("VBScript.RegExp")
    
    '正規表現の指定
    With reg
        .Pattern = ">([^<>\n]+?)<"
        .Global = True
    End With
    
    s = [A1].Value(xlRangeValueXMLSpreadsheet) 'セルの XMLスプレッドシート形式の値を返す
    Set matches = reg.Execute(s)
    c = matches.Count
    
    If c = 0 Then Exit Sub
    
    With udtary
        ReDim .udtarytext(c)
        For j = 1 To c Step 1
          With .udtarytext(j)
              .bfTx = matches(j - 1).submatches(0)
              udtary.bfstr = udtary.bfstr & .bfTx
              .st = Len(udtary.bfstr) - Len(.bfTx) + 1
              .ln = Len(.bfTx)
          End With
          
        Next
        '★先頭大文字変換
        .afstr = StrConv(.bfstr, vbProperCase)
        ''★大文字変換
        '.afstr = StrConv(.bfstr, vbUpperCase)
        ''★小字変換
        '.afstr = StrConv(.bfstr, vbLowerCase)
        For j = 1 To c Step 1
          With .udtarytext(j)
              .aftx = Mid(udtary.afstr, .st, .ln)
          End With
          p = matches(j - 1).FirstIndex       'マッチ個所の位置(0オリジンであることに注意)
          ss = matches(j - 1).submatches(0)   'マッチした部分文字列
          s = Left(s, p + 1) & udtary.udtarytext(j).aftx & Mid(s, p + 2 + Len(ss))
        Next
    End With
    [B1].Value(xlRangeValueXMLSpreadsheet) = s
End Sub

 
標準モジュールに構造体記載
Public Type aryText
  bfTx As String
  aftx As String
  st As Long
  ln As Long
End Type

Public Type ary
 bfstr As String
 afstr As String
 udtarytext() As aryText
End Type

 
 
 
[A1]と[B1]の部分を引数で渡したターゲットのセルにして、
変換方法なども引数で渡したら、ユーザーフォームの条件指定にも対応できました。
明日その他の変換のもろもろに落とし込んで試してみて、
動作を確認してから解決もしくは再質問とさせていただこうと思います。
 
ありがとうございます。

投稿日時: 23/11/28 23:22:55
投稿者: O.M

半角全角の変換にも反映させようとしたのですが
半角はうまくいきますが半角→全角で文字化けしてしまいました。
どこで間違えているのかがわからないため教えていただきたいです。
  
  
  
A1セル
リモデルタイプ >([^<>;\n]+?)< Sh596bayr(密結タンク 手洗なし/フタ固定あり) Tcf5851au(ウォシュレットアプリコットp Ap6a
  
A1セルを選択した状態で下記コード実行
'半全角 設定

Sub test()
  Dim rn As Range, ChangeText As String, conversion As Variant
  Dim TargetCell As Range
  conversion = vbWide
  On Error GoTo ErrHndl
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For Each TargetCell In Selection.Cells
    Set rn = TargetCell
    '数字変換
'    If CheckBox5.Value = True Then
      ChangeText = "[0-9]"
      ZenHanConvert rn, ChangeText, conversion
'    End If
    '英字変換
'    If CheckBox6.Value = True Then
      ChangeText = "[A-Z,a-z]"
      ZenHanConvert rn, ChangeText, conversion
'    End If
    'カタカナ変換
'    If CheckBox7.Value = True Then
      ChangeText = "[ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
'    End If
    '記号変換
'    If CheckBox8.Value = True Then
      ChangeText = "[!0-9,A-Z,a-z,ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
'    End If
  Next
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

 
スプレッドシートを使用しての変換ですと文字化けして変換後の文字が
リモテ゛ルタイフ゜ &amp;gt;([^&amp;lt;&amp;gt;;\n]+?)&amp;lt; Sh596bayr(密結タンク 手洗なし/フタ固定あり) Tcf5851au(ウォシュレットアフ゜リコットp Ap6a
になってしまいます。
Public Function ZenHanConvert(rn As Range, ChangeText As String, conversion As Variant)
    Dim reg As Object
    Dim matches As Object
    Dim m As Object
    Dim c&, j&, p&, s$, ss$
    
    Dim udtary As ary
    
    
    Set reg = CreateObject("VBScript.RegExp")
    
    '正規表現の指定
    With reg
        .Pattern = ">([^<>\n]+?)<"
        .Global = True
    End With
    
    s = rn.Value(xlRangeValueXMLSpreadsheet) 'セルの XMLスプレッドシート形式の値を返す
    Set matches = reg.Execute(s)
    c = matches.Count
    
    If c = 0 Then Exit Function
    
    With udtary
        ReDim .udtarytext(c)
        For j = 1 To c Step 1
          With .udtarytext(j)
              .bfTx = matches(j - 1).submatches(0)
              udtary.bfstr = udtary.bfstr & .bfTx
              .st = Len(udtary.bfstr) - Len(.bfTx) + 1
              .ln = Len(.bfTx)
          End With
        Next
        
        For j = 1 To Len(.bfstr) Step 1
          If Mid(.bfstr, j, 1) Like ChangeText Then
            .afstr = .afstr & StrConv(Mid(.bfstr, j, 1), conversion)
          Else
            .afstr = .afstr & Mid(.bfstr, j, 1)
          End If
        Next j
        
        For j = 1 To c Step 1
          With .udtarytext(j)
              .aftx = Mid(udtary.afstr, .st, .ln)
          End With
          p = matches(j - 1).FirstIndex       'マッチ個所の位置(0オリジンであることに注意)
          ss = matches(j - 1).submatches(0)   'マッチした部分文字列
          s = Left(s, p + 1) & udtary.udtarytext(j).aftx & Mid(s, p + 2 + Len(ss))
        Next
    End With
    rn.Value(xlRangeValueXMLSpreadsheet) = s
End Function

  
Charactersでの半全・全半 変換に差し替えると
うまくいくのですがご指摘のように処理が重いです。
'★却下 Charactersでの半全・全半 変換
Public Function ZenHanConvert(rn As Range, ChangeText As String, conversion As Variant)
  Dim i As Long, j As Long
  '数式、文字列型以外の値は対象外
  If rn.HasFormula Then Exit Function
  If VarType(rn.Value) <> vbString Then Exit Function
  '文字の変換
  j = rn.Characters.Count
  On Error GoTo ErrHndl
  For i = 1 To j
    With rn.Characters(i, 1)
      If .Text Like ChangeText Then
          .Text = StrConv(.Text, conversion)
      End If
    End With
  Next i
ErrHndl:
End Function

回答
投稿日時: 23/11/29 07:37:39
投稿者: simple

上手く動作しなかった理由は尋ねられるまでもなく、ご賢察のとおりです。
とある質問掲示板で議論された手法でしたが、
特定の書式を持つ文字列を一括して削除するとか、逆に特定の文字列に対して一括して書式を
設定するとか、そういった使い方が中心になりそうです。
文字列そのものに特定の変換をしようとすると特殊文字等が悪さをするので、
その前後で回避処理が必要になりますね。
そうした文字列が頻出するのであれば適用が難しいかもしれませんね。
 
そもそも書式も多用し細かい文字列変換を頻繁に行うのであれば、
それは本来はWordの出番かもしれません。その旨お伝えして、私はここまでとします。

投稿日時: 23/11/29 09:46:35
投稿者: O.M

引用:
上手く動作しなかった理由は尋ねられるまでもなく、ご賢察のとおりです。

 
申し訳ないです、カンで目星つけて思い当たる方法をひたすら試してみるという力技で
試しているだけなので、内容が理解できていないです。
 
 
なんとなく
「HPのソースのような雰囲気の文字列を、構造体に収めて、
その中から文字の部分の配列を抜き出してそこを変換しているっぽい…?」
と考えていました。
 
    '正規表現の指定
    With reg
        .Pattern = ">([^<>\n]+?)<"
        .Global = True
    End With

 
の部分がなにかよくわからないけれどHPのソースっぽい文字列を構造体に収める際の法則的なものかなと
想像していました、内容はわからないので自分では一切触れることができません。
 
 
">([^<>\n]+?)<"の部分がデータを区切る法則なら、
同じ文字があると不具合が出ることがもしかしてあるかもしれないと試してステップ実行すると、
matches(j - 1).submatches(0)のところで入手した該当部分のデータの文字列は文字化けしたようなものになっており、
それが原因かと当初かんがえました。
 
しかし、大文字小文字変換の場合も、全角半角変換の場合も同じように文字化けしたようなデータに
なっていましたが、最終的には文字化けしていないデータとなります。
 
matches(j - 1).submatches(0)で入手した時点では文字化けのような文字になっているのは共通なのに、
結果の時点では大文字小文字変換の場合と、全角半角変換の場合にはうまくいき、
半角から全角の場合のみ文字化けのようになる理由がよく分からず迷走してます。
 
それで半角→全角の際にのみうまくいかないのは、
バイト数も関係あるのかと考えて、strt位置がずれないように最後に文字を組み上げる際は
stepを-1にしなければいけないのかと思い
(LENとあったので最初、文字数のみの問題でバイト数は関係ないのかと考えていました)
 
    With udtary
        ReDim .udtarytext(c)
        For j = 1 To c Step 1
          With .udtarytext(j)
              .bfTx = matches(j - 1).submatches(0)
              udtary.bfstr = udtary.bfstr & .bfTx
              .st = Len(udtary.bfstr) - Len(.bfTx) + 1
              .ln = Len(.bfTx)
          End With
        Next

        For j = 1 To Len(.bfstr) Step 1
          If Mid(.bfstr, j, 1) Like ChangeText Then
            .afstr = .afstr & StrConv(Mid(.bfstr, j, 1), conversion)
          Else
            .afstr = .afstr & Mid(.bfstr, j, 1)
          End If
        Next j

        For j = 1 To c Step 1
          With .udtarytext(j)
              .aftx = Mid(udtary.afstr, .st, .ln)
          End With
        Next
        
        For j = c To 1 Step -1
          p = matches(j - 1).FirstIndex       'マッチ個所の位置(0オリジンであることに注意)
          ss = matches(j - 1).submatches(0)   'マッチした部分文字列
          s = Left(s, p + 1) & udtary.udtarytext(j).aftx & Mid(s, p + 2 + Len(ss))
        Next
        
    End With

 
としてみても変わらなかったため、質問させていただいた次第でした。

投稿日時: 23/11/29 10:07:24
投稿者: O.M

引用:
そもそも書式も多用し細かい文字列変換を頻繁に行うのであれば、
それは本来はWordの出番かもしれません。

 
現時点ではExcelで作業したいと考えておりましてWordは考えておりません。
 
 
作業詳細としては、建築の仕上表をエクセルで作成し、
土器手 茂 さんという方が公開してくださっているExcel to Jw_winというソフトを使用して
Jw_cadという製図ソフトにクリップ―ボードを経由してExcelで作成した表を貼り付けています。
 
エクセルで作成している理由ですが、並べ替え等ができて取り出したいデータの抽出や
変更があった部分の抜き出しが行いやすいためそのようにしています。
機器の品番が変わった部分などをセル内で文字色を替えてわかるようにしたりするために、
セル内の文字列の書式変更しています。
 
Jw_cadの文字列もExcelに取得できるのですが、元データの全角半角や大文字小文字の書き方の法則が
ばらばらで整理したいときなどにアドインを使って文字列を変換しています。
(今回質問部分がここになります)
 
Wordをほとんど使用しないためよくわかっていないのですが、
Wordで表の並べ替えや整理などは行いにくいという認識です。
 
的はずれなことを書いていたり、Wordで作業しやすい方法があるというのでしたら教えていただきたいです。
よろしくお願いいたします。

回答
投稿日時: 23/11/30 14:08:38
投稿者: simple

いくつかメモしておきます。
(1)
">([^<>\n]+?)<"という正規表現のパターンは、XMLSpreadsheet形式文字列のなかの、
タグに含まれない文字列を取り出すものです。
(2)
XMLSpreadsheet形式というのは、XMLという規約に使用して、セルの値や書式などを保持する
ための仕組みです。
(ご承知のとおり、OfficeファイルはZIP圧縮されたXMLファイル群ですから、もともとXMLとは
  親和性があります)
 
ご承知のとおり、XMLというのは、例えば"<"や">"と言った文字をタグ表現に使用します。
セルの値そのものに"<"や">"が含まれる場合、それをそのまま保持するとタグと誤認識されるため不都合です。
そこで、"<"は "&lt;" に、">"は "&gt;" といった文字列に変換するわけです(エスケープ処理ですね)。
これら"&lt;"や"&gt;"などは"文字実体参照"と呼ばれて規定されています。
このほか、"&",ダブルクオーテーションなどもそうです。
(これ以外に、場合によっては"文字数値参照"という形式が使われることがあるかもしれません。)
# なお、これらのことは百も承知のうえで、きちんと説明せよ、という意図で発言されているものと想像しています。
(3)
半角→全角変換などで、文字実体参照のまま使うと全角変換された文字実体参照が残るのは当然です。
すでに書きましたが、
・取り出したXMLSpreadsheet形式文字列の、タブに含まれない分(以下、本文)を取り出し、
・本文の中の文字実体参照をいったん通常文字に置換し、
  (置換の順序にも注意が必要です。(&の扱いについて))
・置換処理
・最後にもう一度、文字実体参照への置換
という処理をすべての本文で繰り返せば可能は可能です。
 
(4)
なお、<Cell>と</Cell>で囲まれた箇所だけを対象に置換を実行する工夫をすると、
それ以外の部分も含めて行う不要な文字列連結処理を避けることができるでしょう。
(5)
ただこうなると、複雑化しますので、多少遅くても、確実に実行できるほうがよいかもしれません。
(6)
なお、Word使用に誤解があるようですが、Excelを使わないようにして、
全体をWordで代替せよなどと言うことは一度も申し上げていません。
今回のような文字列処理に限定した部分の提案でした。
> セル内の文字の部分的に変更している文字色や太字指定やフォントなどが消えてしまいます
ということはWordでは起きません。
Ctrl+C,Ctrl+Vで両者を互いに行き来できますし、文字列の書式を保持したままの置換処理は
Wordの得意とするところですから、有益と思ったまでです。
Wordの併用は時々議論されるテクニックではあります。
ご自由に取捨選択下さい。

回答
投稿日時: 23/11/30 14:25:49
投稿者: Suzu

少なくとも、単に セルの値(Value)に対し テキスト置換を行うと、フォント等の情報は破棄されます。
 
それは、一般機能の 置換を行っても同じですから、すぐ確認できます。
 
 
これは、Excel は 表計算ソフトであり、文字をどう見せるか 等の 機能は
後付けの機能なのです。
 
極端な説明としては
セルの 〇文字目から 〇文字目 まで は △ のフォント ・色 等の情報の持ち方をしています。
その中で、文字数の違う文字で置換した場合 意図したフォントの範囲が変わる。
 
置換機能では、単なる 文字 として置換するだけで
 
仮に
 あしたははれです。
 
 から、置換を使い、「ははれ」を、「の天気はくもり」に置換する様な場合
 先の説明の様な フォント情報の持ち方の場合
 
 あしたの天気はくもりです。
 
 の様になってしまいます。
 色を変える意味もなくなってしまうので、継承しない様になっていると思われます。
 
 
それを扱う為に、後付けで、Characters が用意さたのだと思います。
 
それを使わずに
フォント情報が、タグで囲まれた範囲 について、そのタグを適用し
フォント色を表現するスプレッドシート を使えば
実現できるかもね〜 という情報なのです。
 
 
Word は もともと 文字を 見せる為のソフトであり
フォント等の機能もExcelに比べれば充実しており、Excel に比べれば 細かに設定できます。
 
それぞれのアプリケーションの特徴を理解し
それを、ご自身の希望に合う様に コーディングを行うのは 質問者の方です。
 
回答者は、サンプルを提示しますが
その コードの動作、意図を理解しようともせずに、
適当にいじってみて うごかないから どうしたら良いですか?
ではなく、理解してみようと調べ、努力してみましょう。
 
そのうえで、具体的なここのコードの意味が分からないや、ここのコードの意図がわかない
の様な、質問の仕方を心がけてみてください。
 
動けば良いや と言うような感じですと、
よっぽど 回答者の興味を引く様な内容でないと、具体的なコードは得られないですよ。

投稿日時: 23/11/30 20:56:38
投稿者: O.M

simpleさん
Suzuさん
 
丁寧にありがとうございます、若干糸口が見えだす可能性がでてきた気がします。
お答えいただいた内容が理解できない部分も多分にあるのでしばらく調べてみます。
 
また非常に的外れで失礼な質問だったようで申し訳ありません。
わからないことだらけで理解するには全部質問しなければならないくらいの状態のため、
何とか考えて関連していそうな部分に絞って考えて質問をしたつもりでした。
申し訳ありません。
 
 
伝わるかどうかがわからないのですが、四字熟語を検索して日本語の説明文をみて意味を理解していたら、
語源が漢文だからそちらほうがしっかりわかりますよと全然勉強していない
漢文を提示された状態に近いといいますか…。
 
なんとなく漢字の雰囲気で推察しては見るものの、
構文も何もわからないので理解できるようになるにはどれだけ時間がかかるのかと
若干途方に暮れているような状態です。
 
コードを部分的に分解して検索してみても説明文が呪文のように見えて理解ができておりません。
読めばわかるだろうと思われるかもしれませんが読んでもわからない状態です…。
 
 
 
おそらく呆れるレベルで理解ができていないため収集が付かなくなってしまうとは思うのですが、
どのくらい理解ができていないのがわかりやすくなると思いますので、
1個目にお答えいただいた部分でわからない部分を詳しく書いてみます。
※改めて調べてはみます。
 

引用:
(1)
">([^<>\n]+?)<"という正規表現のパターンは、XMLSpreadsheet形式文字列のなかの、
タグに含まれない文字列を取り出すものです。

 
「XMLSpreadsheet形式文字列のなかのタグ」がすでに分からなかったです。
XMLSpreadsheet形式文字列 や XMLSpreadsheet形式文字列 一覧
等で検索しHPは見てみたのですが、理解するには至っておりません。
 
関係ないかもしれませんが、\sを\nに変更すると教えていただいた際に、
CreateObject("VBScript.RegExp") \n
で検索して見つけた下記のサイトで
https://excel-ubara.com/excelvba4/EXCEL232.html
\nが改行のことで、\sがスペースの事なのかなと判断していました。
 
ただ、上手くいかなかった文字として提示させていただきました、
リモデルタイプ SH596BAYR(密結タンク 手洗なし/フタ固定あり) tcf5851AU(ウォシュレットアプリコットP AP2AF)
はセル内で改行をしておりませんし、文字列内にスペースがあるので
\sがスペースで\nが改行だとすると、スペースだとmatches.Countが0で、
改行の\n変えたらmatches.Countが0でなくなる意味が理解できなかったです。
 
() 複数の句をグループ化して、1つの句を作成します。ネストすることができます。 "(ab)?(c)" は "abc" または "c" にマッチします。
などともあったので、
">([^<>\n]+?)<"の部分は組み合わせ方で意味が変わってきそうだけれど
なぜその文字を選んでどういう理由で組み合わせているのかがわからず放置してしまいました。
 
また、matches.Countが0と書いたのは、内容を理解したわけではなく、
ステップ実行してコードの動きを見て
For j = c To 1 Step -1の部分の処理に入らなかったので、
ウォッチウインドウでデータを確認したところcが0だったので、
ループ処理にはいれなかったのは0になっているのが原因のような気がすると思い、
見たままの内容で質問しました。
 
 
加えて初歩の初歩であろうとこでわからないのですが、
 
s = [A1].Value(xlRangeValueXMLSpreadsheet) 'セルの XMLスプレッドシート形式の値を返す

の部分をステップ実行で見てみたら中身が
 
"<?xml version="1.0"?>
<?mso-application progid="Excel.Sheet"?>
<Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet"
 xmlns:o="urn:schemas-microsoft-com:office:office"
 xmlns:x="urn:schemas-microsoft-com:office:excel"
 xmlns:ss="urn:sch
 
となっており、エクセルバージョン情報っぽそうと思ったのですが、
 
Set matches = reg.Execute(s)
 
でいきなりmatchesで構造体(?)っぽいものに格納データのような状態ででてくるため、
何をどうしてそうなったのかが把握できない状態でした。
 
s = [A1].Value(xlRangeValueXMLSpreadsheet)

の部分でA1セルの文字をHPのソースっぽい文字列に変換しているのかと考えていたのですが、
sはxlRangeValueXMLSpreadsheet形式の情報っぽくみえ、
A1セルの文字列がどこに行ったか分からないといった思考状態です。
 
Set matches = reg.Execute(s)
を構造体のItemとValueの部分に文字列が出てくるので、
">([^<>\n]+?)<"と指定した法則でHPのソースっぽい文字列を分解して格納しているのかなと考えました。
 
それでmatchesの構造体を開いていってもそのHPのソースっぽいと予想した文字列が見つけれず、
だけれども、FirstIndexの数値はやたらと大きい数字なのでなんだか長い文字列はどこかにあるはずという予想でした。
 
わかってなさ過ぎて上に書いた文章も意味不明になってしまっていそうな気もしますが、
少しでもマシになるようにしばらく調べる作業に入ります。

回答
投稿日時: 23/11/30 22:39:19
投稿者: simple

(1)
正規表現は、大抵のプログラム言語がカバーしているツールです。
イメージとしてはワイルドカードの拡張版と言った感じですが、
結構色々な機能があり、なかなか一言で説明して理解してもらえる感じでは正直ありません。
ネット上の記事などを参考に各種の使い方を試す経験を経ないと分かりにくいと思います。(私も中級レベルです)
 
参照記事は、以下があります。
 
正規表現とは
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392149(v=msdn.10)
 
RegExp オブジェクト
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392403(v=msdn.10)
 
ここから辿れると思いますが、例えば、executeメソッドの使い方は、下記参照。
https://learn.microsoft.com/ja-jp/previous-versions/windows/scripting/cc392427(v=msdn.10)
# URLは、最後まで選択してコピーし、ブラウザーに貼り付けて閲覧してください。
 
(2)

s = [A1].Value(xlRangeValueXMLSpreadsheet)
について、ステップ実行で見たそうですが、それは一部分です。
イミディエイトウインドウで
?s
などとして、全体を見て下さい。

投稿日時: 23/12/01 09:26:34
投稿者: O.M

simpleさん
 
色々と教えていただきありがとうございます。
じっくり勉強いたします。
 
s = [A1].Value(xlRangeValueXMLSpreadsheet)
のご説明、ありがとうございます。
勘違いで初っ端からつまずいておりました。
 
自分の文字を見たら中身で書いた文字に"の終りの部分がないので、
冷静に考えれば途中とわかりそうなものなんですが、
「見たことのない一気に構造体へ処理するためのすごいコード」といった認識になってしまっており、
思い込みで全然気がつけない状態でした。
 
中身を見たら何が起こっているかを確かめることができるので、
かなり理解しやすくなると思います。
 
ありがとうございます。
 
 

回答
投稿日時: 23/12/05 11:51:26
投稿者: simple

Wordを援用する方法のプロトタイプを示しておきます。
 
・メリットとしては、書式を気にせずに置換ができる点。
  置換前後で文字数が増減するパターンも問題なく実行できる点。
・デメリットとしては速度が遅い点(トレードオフかもしれません)
 
Option Explicit
Rem ■Word(Microsoft Word xx.x Object Library)の参照設定が必要■
Dim wd As Word.Application, doc As Word.Document

Sub main()
    'Wordオブジェクトをセット
    Call initialize

    'Wordに転記
    Range("A1:A20").Copy                '一例
    wd.Selection.PasteExcelTable False, False, False
    Application.CutCopyMode = False     ' ■重要。削除不可。

    '''Call myConvert
    Call 英単語文字種変換(wdLowerCase)

    'Excelに戻す    
    doc.Tables(1).Range.Copy
    Range("B1").Select
    ActiveSheet.Paste
End Sub

Sub initialize()
    'Wordオブジェクトを設定
    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    If wd Is Nothing Then
        Set wd = CreateObject("Word.Application")
        wd.Visible = True
        Set doc = wd.Documents.Add
    End If
    On Error GoTo 0

    Set doc = wd.ActiveDocument
    'Documentの初期化
    doc.Content.Select
    wd.Selection.Delete
End Sub

Function 全角半角変換(CPattern As Long)
    wd.Selection.HomeKey Unit:=wdStory
    wd.Selection.Find.ClearFormatting
    wd.Selection.Find.Replacement.ClearFormatting
    With wd.Selection.Find
        Select Case CPattern
            Case 1: .Text = "[A-Za-z0-9]{1,}"           '英数半角
            Case 2: .Text = "[A-Za-z0-9]{1,}"     '英数全角
            Case 3: .Text = "[ヲ-ン]{1,}"                 'カタカナ半角
            Case 4: .Text = "[ア-ン]{1,}"               'カタカナ全角
            Case 5: .Text = "[A-Za-z0-9ヲ-ン]{1,}"        '両方半角
            Case 6: .Text = "[A-Za-z0-9ア-ン]{1,}"    '両方全角
        End Select
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = False
    End With
    Do While wd.Selection.Find.Execute = True
        With wd.Selection
            Select Case CPattern
                Case 1, 3, 5: .Range.Case = wdFullWidth
                Case 2, 4, 6: .Range.Case = wdHalfWidth
            End Select
            .Collapse Direction:=wdCollapseEnd
        End With
    Loop
End Function

Function 英単語文字種変換(CPattern As Long)
    ''' CPattern
    'wdLowerCase     0       小文字。
    'wdUpperCase     1       大文字。
    'wdNextCase      -1      大文字、小文字、文の先頭文字を大文字、の間で切り替えます。
    'wdTitleSentence 4       文の先頭文字を大文字にします。
    'wdTitleWord     2       タイトル文字列を大文字にします。
    'wdToggleCase    5       大文字は小文字に、小文字は大文字に切り替えます。
    
    wd.ScreenUpdating = False
    wd.Selection.HomeKey Unit:=wdStory
    wd.Selection.Find.ClearFormatting
    wd.Selection.Find.Replacement.ClearFormatting
    With wd.Selection.Find
        .Text = "[A-Za-zA-Za-z]{1,}"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
    End With
    Do While wd.Selection.Find.Execute = True
        With wd.Selection
            .Range.Case = CPattern
            .Collapse Direction:=wdCollapseEnd
        End With
    Loop
    wd.ScreenUpdating = True
End Function

Function myConvert()    ’一般的な置換の例
    wd.Selection.HomeKey Unit:=wdStory
    wd.Selection.Find.ClearFormatting
    wd.Selection.Find.Replacement.ClearFormatting
    With wd.Selection.Find
        .Text = " "                 '半角スペース
        .Replacement.Text = " "    '全角スペース
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True           '全角半角区別
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = False
    End With
    wd.Selection.Find.Execute Replace:=wdReplaceAll
End Function

なお、上記の置換処理は標準的なものかと思います。色々なところに転がっているでしょう。
予想以上に Wordの置換処理が遅くて驚きました。
(しかも、Excelから実行するとさらに遅くなりますね。なにか間違っているのですかね。)

回答
投稿日時: 23/12/05 21:10:37
投稿者: simple

XMLスプレッドシート形式を利用したコードを書いておきます。
# 十分な検証をしていないので、ミスがありえます。
 
ここでは、複数セルからなる矩形範囲のXMLSpreadsheetをひとつの文字列に纏めて取得し、加工しています。
 
速度的には、Word援用が10秒弱かかっているのに対して、0.04秒くらいで済んでいます。
 
置換前後で文字数が変わらないものは、Charactersを直接更新したほうがトータルでは手間が
かからないかもしれません。
文字数が増えたり、細かい芸を必要とする場合は、Word援用とか、XMLスプレッドシート形式
データの利用とかを考えるとよいものと思われます。
 
以下、参考コードです。
 
Option Explicit
 
Dim reg As Object
Dim reg2 As Object

Sub main()
    Dim xml   As String
    Dim rng   As Range
    Dim ary   As Variant
    Dim s     As String
    Dim k     As Long
    
    'myConvertプロシージャで使用するための準備
    If reg Is Nothing Then
        Set reg = CreateObject("VBScript.RegExp")
        Set reg2 = CreateObject("VBScript.RegExp")
    End If
    
    '対象とする矩形範囲を指定
    Set rng = [A1:A20]   '複数セルからなる矩形範囲を指定可能

    '矩形範囲のXMLスプレッドシート形式を取得
    xml = rng.Value(xlRangeValueXMLSpreadsheet)
    'xmlをいくつかの文字列要素の配列に分割
    ary = mySplit(xml, rng.Columns.Count)
    
    For k = 0 To UBound(ary)
        s = ary(k)
        If Left(s, 5) = "<Cell" Then
            ary(k) = myConvert(s)   '本文を置換
        End If
    Next

    '置換結果を書きこみ
    [B1:B20].Value(xlRangeValueXMLSpreadsheet) = Join(ary, "")
End Sub

'xmlを各要素に分解
Function mySplit(xml$, colCount As Long) As Variant
    Dim matches As Object
    Dim m     As Object
    Dim sm    As Object
    
    Dim header$, footer$, body$
    Dim p1 As Long, p2 As Long
    Dim ary() As String         '作成する配列(要素は文字列)
    Dim n     As Long
    Dim j     As Long
    Dim pat   As String

    'xmlテキストを分割
    p1 = InStr(xml, "<Row")
    p2 = InStrRev(xml, "</Row>") + 7
    header = Left(xml, p1 - 1)          'セル範囲より前の部分
    body = Mid(xml, p1, p2 - p1)        'セル範囲部分
    footer = Right(xml, Len(xml) - p2)  'それ以後の部分

    '各要素をさらに分割して配列に保存
    n = 0
    ReDim ary(n)
    ary(n) = header

    'セル範囲部分を更に要素に分離
    With CreateObject("VBScript.RegExp")
         pat = "(<Cell[^>]*>[\s\S]*?</Cell>\s*)?"
        .Pattern = "(<Row[^>]*?>\s*)" _
                & Application.Rept(pat, colCount) _
                & "(</Row>\s*)"
        '' 列の数だけ<Cell>...</Cell> が繰り返し出現。
        '' それらをひとつづつ部分文字列として持つためには、その回数だけ繰り返し記述
        .Global = True
        Set matches = .Execute(body)
        For Each m In matches
            For j = 0 To m.SubMatches.Count - 1
                n = n + 1
                ReDim Preserve ary(0 To n)
                ary(n) = m.SubMatches(j)
            Next
        Next
    End With
    
    'フッター部分
    ReDim Preserve ary(0 To UBound(ary) + 1)
    ary(UBound(ary)) = footer
    
    mySplit = ary
End Function

'文字列の置換処理
Function myConvert(s As String) As String
    Dim matches As Object
    Dim m     As Object
    Dim j&, p&, s0$, ss$
    Dim ary As Variant
    
    reg.Pattern = ">([^<>\n]+?)<"  '' "本文"部分を取得
    reg.Global = True
    
    Set matches = reg.Execute(s)  'セル内容のうち"本文"を取り出す
    
    For j = matches.Count To 1 Step -1
        p = matches(j - 1).FirstIndex    'マッチ個所の位置(0オリジンであることに注意)
        s0 = matches(j - 1).SubMatches(0)   '本文部分
        ss = unescapeHTML(s0)   '(1)unescapeを実行
        ss = testConv(ss)       '(2)■ここが変換内容を指定する部分■■■ここを加工。
        ss = escapeHTML(ss)     '(3)再度、escapeを実行
        s = Left(s, p + 1) & ss & Mid(s, p + 1 + Len(s0) + 1)
    Next
    myConvert = s
End Function

Function testConv(ByVal s As String) As String
    '' アルファベットを小文字化
    Dim matches As Object
    Dim j&, p&, s0$, ss$
    reg2.Pattern = "[A-Za-zA-Za-z]{1,}"
    reg2.Global = True
    Set matches = reg2.Execute(s)
    For j = matches.Count To 1 Step -1
        p = matches(j - 1).FirstIndex
        s0 = matches(j - 1).Value
        ss = LCase(s0)
        s = Left(s, p) & ss & Mid(s, p + Len(s0) + 1)
    Next
    testConv = s
End Function

Function escapeHTML(ByVal s As String)
    s = Replace(s, "&", "&amp;")
    s = Replace(s, "<", "&lt;")
    s = Replace(s, ">", "&gt;")
    s = Replace(s, """", "&quot;")
    s = Replace(s, vbLf, "&#10;")  'あえて全角にしているので半角にして下さい。
    s = Replace(s, vbCr, "&#13;")  '同上
    escapeHTML = s
End Function

Function unescapeHTML(ByVal s As String)
    s = Replace(s, "&lt;", "<")
    s = Replace(s, "&gt;", ">")
    s = Replace(s, "&quot;", """")
    s = Replace(s, "&#10;", vbLf)    '同上
    s = Replace(s, "&#13;", vbCr)    '同上
    s = Replace(s, "&amp;", "&")
    unescapeHTML = s
End Function

---------- 以下、余談につきスキップが良いと思います。
ちなみに、何度か書いていますが、VBAのコードがこのように煩雑なものになるのは、
VBScriptの正規表現まわりの機能が低いからです。
正規表現でマッチしたところにコールバック関数的に変換をして置き換える機能が
無いからです。
たとえば、もっと別の言語であれば、以下のようにかなり簡潔に書けます。
(まあ、"無いものねだり"であって如何ともしがたいわけですが。)
 
ご参考^n まで。
 
require 'cgi'
# --------------------------------
f = "test.txt"                 # XMLSpreadsheet形式テキストを読み込む
xml = open(f,"r"){|file| file.read} 

# (1)テーブル部分(<Row>...</Row>) とその前後の3部分に分割     
header,body,footer = xml.scan(/^(.*?)(<Row.*<\/Row>)(.*?)$/m).flatten
#------------------------
# (2)テーブル部分だけを対象に、
#    @<Row>部分、A<Cell>....</Cell>部分,B</Row>部分の繰り返しに分割
colnum = 1                  # test用に予め設定するものとした(セル範囲の列数に相当)
pat = '(<Cell[^>]*>[\s\S]*?<\/Cell>\s*)?'
pattern = '(<Row[^>]*?>\s*)' + pat * colnum + '(<\/Row>\s*)'
ary  = body.scan(/#{pattern}/m).flatten  # 要素に分割
#--------------------------
# (3)書式のタグなどを除いた、セルの値部分を取り出し、所要の置換を施す
ary.each_with_index{|x,k|
    unless x == nil
        if x =~ /^<Cell/ 
            x.gsub!(/>([^<>\n]+?)</){
                s = $1
                s = CGI.unescapeHTML(s)  #  例:  &amp; を &  に戻す
                s = s.downcase
                s = CGI.escapeHTML(s)    #  例:  & を  &amp; に置換
                ">" + s + "<"  
            }
        end
    end
}
# 結果を文字列連結して出力
puts  [header, ary, footer].join 

投稿日時: 23/12/05 21:45:59
投稿者: O.M

simpleさん
  
いろいろとありがとうございます。
  
わかっていなかったことにやっと気が付いたら更に調べることがどんどん増えて行って…
といったじょうたいで、遅々として進んでいない状態で、
ワード変換のところまでたどり着いていませんでした。
  
※simpleさんがstep実行をマイナスで行っていたのは、
濁点や半濁点のカタカナの半角や全角変換で文字数が変わってくるからそれに配慮してのこともあっのかなと
遅ればせながらやっと思い至ったり、
セルの書式設定によってもいろいろ変換が変わることにやっと気が付いたりと、
初歩の初歩の部分でつまずきまくっておりました。
  
まだまだ相当な時間かかりそうなのですが、
教えていただいたこと糧に頑張って勉強します。
ありがとうございます。

投稿日時: 23/12/06 22:38:22
投稿者: O.M

教えていただいたコードはまだまだ勉強中で、全然使えるような状態にできていないのですが、
差し当って作業するためにCharactersでの変換のほうを修正して使用しておりまして、
自分が使用する範囲では希望の変換になる様にはできたので参考までに張っておきます。
動きはしますがめちゃくちゃ遅いです…。
※コード間違っていたので削除して訂正しました。
   
変換して希望道理にならず修正した変更箇所としては下記の2点です。
   
1.濁点や半濁点付きの文字で全角は1文字なのに、半角にすると2文字になる場合の考慮
バ→バ
の場合、半角ですと半角にした際に「ハ」と「゙」に分かれてしまい
バ→バ
で再度全角に変換した際に「ハ」と「゙」にわかれてしまうので、
「ハ」と「゙」の書式が違うパターンなどは考えずに、
「ハ」の位置に「バ」をいれて「゙」は空白文字の""をいれるようにしました。
   
2.機種依存文字を変換するとクエスチョンマークになってしまう点に関する修正
変換前がクエスチョンマーク以外でかつ変換後にクエスチョンマークになる場合は無変換
   
   
選択範囲のセルの文字の書式を維持して全角半角変換

'全角→半角変換 設定
Sub ZenHan()
  Dim TargetCell As Range
  Dim rn As Range, ChangeText As String, conversion As Variant
  Dim Kazu As Boolean, Eizi As Boolean, Kana As Boolean, Kigo As Boolean
  
  '半角変換
  conversion = vbNarrow
  
  '【変換設定】
  'Trueで変換、Falseで変換なし
  Kazu = True  '数字変換
  Eizi = True  '英字変換
  Kana = True  'カタカナ変換
  Kigo = True  '記号変換
  
  On Error GoTo ErrHndl
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For Each TargetCell In Selection.Cells
    Set rn = TargetCell
    '数字変換
    If Kazu = True Then
      ChangeText = "[0-9]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    '英字変換
    If Eizi = True Then
      ChangeText = "[A-Z,a-z]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    'カタカナ変換
    If Kana = True Then
      ChangeText = "[ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    '記号変換
    If Kigo = True Then
      ChangeText = "[!0-9,A-Z,a-z,ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
    End If
  Next
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

'半角→全角変換 設定
Sub HanZen()
  Dim rn As Range, ChangeText As String, conversion As Variant
  Dim TargetCell As Range
  Dim Kazu As Boolean, Eizi As Boolean, Kana As Boolean, Kigo As Boolean
  
  '全角変換
  conversion = vbWide
  
  '【変換設定】
  'Trueで変換、Falseで変換なし
  Kazu = True  '数字変換
  Eizi = True  '英字変換
  Kana = True  'カタカナ変換
  Kigo = True  '記号変換
  
  On Error GoTo ErrHndl
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For Each TargetCell In Selection.Cells
    Set rn = TargetCell
    '数字変換
    If Kazu = True Then
      ChangeText = "[0-9]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    '英字変換
    If Eizi = True Then
      ChangeText = "[A-Z,a-z]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    'カタカナ変換
    If Kana = True Then
      ChangeText = "[ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
    End If
    '記号変換
    If Kigo = True Then
      ChangeText = "[!0-9,A-Z,a-z,ア-ン]"
      ZenHanConvert rn, ChangeText, conversion
    End If
  Next
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

'★Charactersでの半全・全半 変換
Public Function ZenHanConvert(rn As Range, ChangeText As String, conversion As Variant)
  Dim i As Long, j As Long
  '数式、文字列型以外の値は対象外
'  If rn.HasFormula Then Exit Function
'  If VarType(rn.Value) <> vbString Then Exit Function
  '文字の変換
  j = rn.Characters.Count
  On Error GoTo ErrHndl
  For i = j To 1 Step -1
    With rn.Characters(i, 1)
       If (.Text Like "[?,?]") Or (.Text <> "?" And .Text <> "?" And StrConv(.Text, conversion) <> "?" And StrConv(.Text, conversion) <> "?") Then
        If .Text Like ChangeText Then
            If conversion = vbWide Then
              If i < j And Len(StrConv(.Text & rn.Characters(i + 1, 1).Text, vbWide)) = 1 Then
                .Text = StrConv(.Text & rn.Characters(i + 1, 1).Text, vbWide)
                rn.Characters(i + 1, 1).Text = ""
              Else
                .Text = StrConv(.Text, conversion)
              End If
            Else
              .Text = StrConv(.Text, conversion)
            End If
        End If
      End If
    End With
  Next i
ErrHndl:
End Function

 
  
  
大文字小文字変換
※実際に使用しているユーザーフォームの設定を選択するコードをそのまま載せていますので、
そのままでは使用できません。
  
’大文字小文字変換 設定
Private Sub CommandButton3_Click()
  Dim conversion As Variant, Text As String
  Dim TargetCell As Range
  '単語先頭を大文字
  If OptionButton1.Value = True Then
    conversion = vbProperCase
  End If
  '大文字変換
  If OptionButton2.Value = True Then
    conversion = vbUpperCase
  End If
  '小文字変換
  If OptionButton3.Value = True Then
    conversion = vbLowerCase
  End If
  '変換
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  On Error GoTo ErrHndl
  For Each TargetCell In Selection.Cells
     '半全・全半 変換
     ProUpLowConvert TargetCell, conversion
  Next
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

'Charactersでの大小 変換
Public Function ProUpLowConvert(rn As Range, conversion As Variant)
  Dim i As Long, j As Long
  Dim Str As String
  '数式、文字列型以外の値は対象外
  If rn.HasFormula Then Exit Function
  If VarType(rn.Value) <> vbString Then Exit Function
  '文字の変換
  j = rn.Characters.Count
  Str = StrConv(rn.Value, conversion)
  On Error GoTo ErrHndl
  For i = j To 1 Step -1
    With rn.Characters(i, 1)
       If (.Text Like "[?,?]") Or (.Text <> "?" And .Text <> "?" And StrConv(.Text, conversion) <> "?" And StrConv(.Text, conversion) <> "?") Then
        Select Case conversion
          Case vbProperCase
            If .Text <> Mid(Str, i, 1) Then
              Select Case Mid(Str, i, 1)
                Case StrConv(.Text, vbUpperCase)
                  .Text = StrConv(.Text, vbUpperCase)
                Case StrConv(.Text, vbLowerCase)
                  .Text = StrConv(.Text, vbLowerCase)
              End Select
            End If
          Case vbUpperCase
            .Text = StrConv(.Text, conversion)
          Case vbLowerCase
            .Text = StrConv(.Text, conversion)
        End Select
      End If
    End With
  Next i
ErrHndl:
End Function

投稿日時: 23/12/07 00:43:12
投稿者: O.M

コードを書いた後にふと気が付いたのですが、
全変換の場合はChangeTextを"*"、記号変換以外の変換はChangeTextを&でつなきStrConvでの変換回数を減らし、
文字を1文字ずつ配列にいれて、配列内で文字変換し、
最後にCharactersと配列を対応させて変換とすればだいぶ早くなりそうな気がします…。
 
そちらの訂正を先にして、その後に教えていただいたコードを使用しての変換の勉強に戻りたいと
思います。

投稿日時: 23/12/07 01:12:27
投稿者: O.M

ワイルドカードの指定を間違っていました。
下記サイトを参考に修正します。
https://stabucky.com/wp/archives/3836
https://stabucky.com/wp/archives/3836#google_vignette

投稿日時: 23/12/08 17:39:17
投稿者: O.M

simpleさん
 
本当にありがとうございます。
進んでいないのですが、経過報告しないと何もしていないように見えるかなと考えまして、
現時点でのご報告です。
 
 
ワードを使用しての変換ですが、下記スレッドで教えていただきました
https://www.moug.net/faq/viewtopic.php?t=82566
サロゲートペア文字や、4バイトを超えるマルチバイト文字
https://excel-ubara.com/excel5/EXCEL886.html
も変換できるのですが、
 
1.セル内で改行された文字が含まれるセルは貼り付け直したときに
  行数が増えてしまい元の場所に貼り付けることができない
 
2.エクセルに貼り付け直した際に罫線が太くなる
 
などの症状があり、調べているのですが、うまく調べることができていません。
 
 
そちらをおいておいて、XMLスプレッドシート形式を利用したコードの方も試させていただいたのですが、
早く綺麗に変換できました。
ただ、サロゲートペア文字や、4バイトを超えるマルチバイト文字に関しては文字化けしました。
変換後に&#から始まる文字に文字化けをするので、そちらを踏まえたら対策できそうな気がするため調べている最中です。
 
正規表現は教えていただいたサイトで個別内容は理解が進んだ気がするのですが、
組み合わせたものを見ると混乱してしまって思考停止に近い状態になってしまっています。
 
XMLスプレッドシート形式を利用したコードのほうが断然早いため、
そちらをベースにどうにかできないかなと考えています。
 
 
 
Charactersでの変換に関しましては、
 
1.自分がワイルドカードの指定を間違っていた点を修正
 
2.サロゲートペア文字や、4バイトを超えるマルチバイト文字に関しての処理
変換後に?や?を含む文字になるので
「変換前に?や?ではない文字で、変換後に?や?を含む文字は変換せずにそのままの文字とする」
という方法で文字化けが回避できました。
 
先頭の文字を大文字に変換関しては、配列にCharactersのtextを一旦入れて、
変換前後および文字化け有無のフラグを立てて、
配列を元に変換指示としようと思って作業中です。
 
 
3.処理速度UP
先にCharactersを使用せずにMIDで文字を割って変換した文字を
最後に1回でまとめてCharacters変換処理をしたら処理速度がUPするかと思ったのですが、
MIDがサロゲートペア文字や、4バイトを超えるマルチバイト文字に対応していないということなので
そちらは諦めました。
 
*やワイルドカード文字は結合して、少しでも処理を早くしようと変更はしましたがやはりかなり遅いです。
 
 
 
 

回答
投稿日時: 23/12/08 21:03:01
投稿者: simple

> 進んでいないのですが、経過報告しないと何もしていないように見えるかなと考えまして、
> 現時点でのご報告です。

わざわざありがとうございます。
でも、私は書きたいことはすべて書きましたし、もう貢献できることも余りありませんので、
気になさらずマイペースでお進めください。
 
> ワードを使用しての変換ですが、下記スレッドで教えていただきました
> https://www.moug.net/faq/viewtopic.php?t=82566
ああ、これは私のこちらのスレッドでのコードの一部が使われている気がしますが、
もしコードの入力負荷軽減に貢献できたのなら幸いです。
 
セル内改行の話は私も気づいていました。
(セル結合や、矩形範囲の途中に空白セルがある場合等のチェックのときに気づきました。
  放置プレーでしたが。)
 
フォント色の変換の話は、こんな風にも書けますね。

Sub test2() 'A1セルの文字色を、青を黒に、赤を青にして、B1セルに書き込む
    Dim colRed$, colBlue$, colBlack$, s$
    
    colRed = "html:Color=""#FF0000""" '赤
    colBlue = "html:Color=""#0000FF""" '青
    colBlack = "html:Color=""#000000""" '黒
    s = [A1].Value(11)
    s = Replace(s, colBlue, colBlack)  '青を黒に
    s = Replace(s, colRed, colBlue)  '赤を青に
    [B1].Value(11) = s
End Sub
これだと 4バイトでも7バイトでも問題なさそうです。
コード自体が他人に分かりにくいですけど。
 
こちらのスレッドに関する検討も進んでいるようですね。頼もしい限りです。

投稿日時: 23/12/09 01:27:11
投稿者: O.M

 

引用:
私は書きたいことはすべて書きましたし、もう貢献できることも余りありませんので、
気になさらずマイペースでお進めください。

 
  
そういっていただけますととてもありがたいです。
見たことのないコードが沢山でとても勉強になっています、ありがとうございます。
  
丸っと答えをいただいた状態に近く、自分用に少し調整すればいいような状態て提示いただいていると
は思うのですが、私の頭が追いついておらず…。
おそらく期間がだいぶ開いてしまうと思うのですが、じっくり調べさせていただきます。
  
  
Charactersでの変換はもう少しなんとかできそうな気はするのですが、
すっきりしたコードが思い浮かばないため口述の分でいったん終了し、
教えていただいたXMLスプレッドシート形式のほうをメインに調べていこうと考えています。
  
※スペース削除に関しては手が付けれていないのですが、
使う頻度は低い事と、他の変換の応用で処理できる気がしますので、
もっと時間ができたときにしようと考えています。
  
  
Charactersを使用した書式や色を維持しての文字の全角半角変換、大文字小文字変換
'【注意】とても動作が遅いです。
 
’複数シート選択の禁止
Private Function SheetCountCheck() As Boolean
  If ActiveWindow.SelectedSheets.Count > 1 Then
    MsgBox "シートが複数選択されています。" & vbLf & "シートの選択は1つとしてください。", vbOKOnly
    SheetCountCheck = True
  End If
End Function
 
'【選択セルの文字の全角半角変換】
'全→半角 設定
Sub ZenHanHenkan()
  Dim rn As Range, ChangeText As String, conversion As Variant
   
  If SheetCountCheck = True Then Exit Sub
     
  conversion = vbNarrow
   
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
   
  On Error GoTo ErrHndl
   
  'Trueで変換、Falseで変換なし
  Kazu = True '数字変換
  Eizi = True '英字変換
  Kana = True 'カタカナ変換
  Kigo = True '記号変換
   
  '全変換の場合
  If Kazu = True And Eizi = True And Kana = True And Kigo = True Then
    ChangeText = "*"
  Else
    '数字変換
    If Kazu = True Then ChangeTextMake ChangeText, "0-9"
    '英字変換
    If Eizi = True Then ChangeTextMake ChangeText, "A-Z,a-z"
    'カタカナ変換
    If Kana = True Then ChangeTextMake ChangeText, "ァ-ヶー"
    If ChangeText <> "" Then
      ChangeText = "[" & ChangeText & "]"
    End If
  End If
  '変換
  For Each rn In Selection.Cells
    '記号のみ以外の変換
    If ChangeText <> "" Then ZenHanConvert rn, ChangeText, conversion
    '記号のみの変換
    If Kigo = True Then ZenHanConvert rn, "[!0-9,A-Z,a-z,ァ-ヶー]", conversion
  Next
   
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub
 
'半→全角 設定
Sub HanZenHenkan()
  Dim rn As Range, ChangeText As String, conversion As Variant
  Dim Kazu As Boolean, Eizi As Boolean, Kana As Boolean, Kigo As Boolean
   
  If SheetCountCheck = True Then Exit Sub
   
  conversion = vbWide
   
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
   
  On Error GoTo ErrHndl
   
  'Trueで変換、Falseで変換なし
  Kazu = True '数字変換
  Eizi = True '英字変換
  Kana = True 'カタカナ変換
  Kigo = True '記号変換
   
  '全変換の場合
  If Kazu = True And Eizi = True And Kana = True And Kigo = True Then
    ChangeText = "*"
  Else
    '数字変換
    If Kazu = True Then ChangeTextMake ChangeText, "0-9"
    '英字変換
    If Eizi = True Then ChangeTextMake ChangeText, "A-Z,a-z"
    'カタカナ変換
    If Kana = True Then ChangeTextMake ChangeText, "ヲ-ンー"
    If ChangeText <> "" Then
      ChangeText = "[" & ChangeText & "]"
    End If
  End If
  '変換
  For Each rn In Selection.Cells
    '記号のみ変換以外の変換
    If ChangeText <> "" Then ZenHanConvert rn, ChangeText, conversion
    '記号のみ変換
    If Kigo = True Then ZenHanConvert rn, "[!0-9,A-Z,a-z,ヲ-ンー]", conversion
  Next
     
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub
 
'ワイルドカード文字の結合
Private Function ChangeTextMake(ChangeText As String, str As String)
     If ChangeText = "" Then
        ChangeText = str
      Else
        ChangeText = ChangeText & "," & str
      End If
End Function
 
'★Charactersでの半全・全半 変換
Public Function ZenHanConvert(rn As Range, ChangeText As String, conversion As Variant)
  Dim i As Long, j As Long
  Dim bfstr As String, str As String
  '数式、文字列型以外の値は対象外
' If rn.HasFormula Then Exit Function
' If VarType(rn.Value) <> vbString Then Exit Function
  '文字の変換
  j = rn.Characters.Count
  On Error GoTo ErrHndl
  For i = j To 1 Step -1
    With rn.Characters(i, 1)
      bfstr = .Text
      str = StrConv(bfstr, conversion)
      If (bfstr = "?" Or bfstr = "?") Or (bfstr <> "?" And bfstr <> "?" And InStr(str, "?") = 0 And InStr(str, "?") = 0) Then
        If bfstr Like ChangeText Then
          If conversion = vbWide Then
            If i < j And Len(StrConv(bfstr & rn.Characters(i + 1, 1).Text, vbWide)) = 1 Then
              .Text = StrConv(bfstr & rn.Characters(i + 1, 1).Text, vbWide)
              rn.Characters(i + 1, 1).Text = ""
            Else
              .Text = str
            End If
          Else
            .Text = str
          End If
        End If
      End If
    End With
  Next i
ErrHndl:
End Function
 
 
 
 
 
’【選択セルの文字の大文字小文字変換】
Sub DaiSyouHenkan()
  Dim conversion As Variant, Text As String
  Dim rn As Range
  Dim Henkan As Long
   
  '複数シート選択の禁止
  If SheetCountCheck = True Then Exit Sub
   
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
   
On Error GoTo ErrHndl
 
  '1 単語先頭を大文字
  '2 '大文字変換
  '3 '小文字変換
  Henkan = 1
 
  '単語先頭を大文字
  If Henkan = 1 Then conversion = vbProperCase
  '大文字変換
  If Henkan = 2 Then conversion = vbUpperCase
  '小文字変換
  If Henkan = 3 Then conversion = vbLowerCase
 
 
   '変換
  For Each rn In Selection.Cells
     '半全・全半 変換
     ProUpLowConvert rn, conversion
  Next
   
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub
 
'Charactersでの大小 変換
Public Function ProUpLowConvert(rn As Range, conversion As Variant)
  Dim i As Long, j As Long
  Dim bfstr As String, str As String, Str2 As Variant, Str3 As String
   
  '数式、文字列型以外の値は対象外
' If rn.HasFormula Then Exit Function
' If VarType(rn.Value) <> vbString Then Exit Function
 
  '文字の変換
  j = rn.Characters.Count
' On Error GoTo ErrHndl
   
  If conversion = vbProperCase Then
    ReDim Str2(1 To 2, 1 To j)
    For i = j To 1 Step -1
      With rn.Characters(i, 1)
        bfstr = .Text
        str = StrConv(bfstr, conversion)
        If InStr(str, "?") = 0 And InStr(str, "?") = 0 And bfstr <> "" Then
          Str2(1, i) = str
          Str2(2, i) = True
        Else
          Str2(1, i) = "あ"
          Str2(2, i) = False
        End If
        Str3 = Str2(1, i) & Str3
      End With
    Next
    Str3 = StrConv(Str3, vbProperCase)
    For i = j To 1 Step -1
      With rn.Characters(i, 1)
        If Str2(2, i) = True Then
          .Text = Mid(Str3, i, 1)
        End If
      End With
    Next
 
  Else
    For i = j To 1 Step -1
      With rn.Characters(i, 1)
        bfstr = .Text
        str = StrConv(bfstr, conversion)
          If InStr(str, "?") = 0 And InStr(str, "?") = 0 And bfstr <> "" Then
            .Text = str
          End If
      End With
    Next i
  End If
ErrHndl:
End Function
 

回答
投稿日時: 23/12/11 09:11:16
投稿者: MMYS

O.M さんの引用:

すっきりしたコードが思い浮かばないため口述の分でいったん終了し、

私だったら、このように書きます。なお、コーディングスタイルは人それぞれ。このように書くべきと主張しているわけでは有りません。あくまで一例です。
 
ユーザーフォーム
Option Explicit

Private Sub CommandButton1_Click()

    Dim convertData(1 To 6) As myConvert
    Dim cb  As MSForms.checkBox
    Dim selectionRange As Range
    Dim i   As Byte

    convertData(1).matchPattern = "[0-9]"
    convertData(1).conversion = vbNarrow
    convertData(2).matchPattern = "[A-Z,a-z]"
    convertData(2).conversion = vbNarrow
    convertData(3).matchPattern = "[ア-ン]"
    convertData(3).conversion = vbNarrow

    convertData(4).matchPattern = "[0-9]"
    convertData(4).conversion = vbWide
    convertData(5).matchPattern = "[A-Z,a-z]"
    convertData(5).conversion = vbWide
    convertData(6).matchPattern = "[ア-ン]"
    convertData(6).conversion = vbWide
  
    'チェックボックスの値取得
    For i = LBound(convertData) To UBound(convertData)
        Set cb = Me.Controls("CheckBox" & i)
        convertData(i).checkboxValue = cb.Value
    Next
    Set cb = Nothing

    '選択範囲のセル値を変換
    Set selectionRange = Selection
    ConvertSelecton selectionRange, convertData '選択範囲を変換
    Set selectionRange = Nothing

End Sub

標準モジュール
Option Explicit

Type myConvert
    checkboxValue   As Boolean      'チェックボックスの値
    matchPattern    As String       'マッチパターン
    conversion      As VbStrConv    '変換方法
End Type

Sub testConvertSelecton()
'単体テスト
  Dim c(0) As myConvert
  c(0).checkboxValue = True
  c(0).matchPattern = "[0-9]"
  c(0).conversion = vbNarrow
  ConvertSelecton Range("A1:A10"), c
End Sub

Public Sub ConvertSelecton(selectionRange As Range, convertData() As myConvert)
'選択範囲のセル値を指定にもとづいて変換します。
'  selectionRange  セル範囲を指定する
'  convertData     変換データを配列で指定する

    Dim TargetCell  As Range
    Dim checkBox    As Boolean
    Dim ChangeText  As String
    Dim conversion  As VbStrConv
    Dim i   As Integer
  
    For Each TargetCell In selectionRange

        For i = LBound(convertData) To UBound(convertData)
            '配列から値を取得
            With convertData(i)
                checkBox = .checkboxValue   'チェックボックスの値
                ChangeText = .matchPattern  'マッチパターン
                conversion = .conversion    '変換方法
            End With

            If checkBox Then    'checkboxがオンなら
                '全角または半角の変換
                ZenHanConvert TargetCell, ChangeText, conversion
            End If

        Next
    Next

End Sub

Sub testConvertSelectonCell()
'単体テスト
  ConvertSelectonCell Range("A1"), "[0-9]", vbNarrow
 'ConvertSelectonCell Range("A2"), "[A-Z,a-z]", vbNarrow
 'ConvertSelectonCell Range("A3"), "[ア-ン]", vbNarrow
 'ConvertSelectonCell Range("A4"), "[0-9]", vbWide
 'ConvertSelectonCell Range("A5"), "[A-Z,a-z]", vbWide
 'ConvertSelectonCell Range("A6"), "[ア-ン]", vbWide
End Sub

Private Sub ConvertSelectonCell(targetRange As Range, matchPattern As String, conversion As VbStrConv)
'全角または半角の変換を行います
'  targetRange  変換対象のRangeオブジェクト
'  matchPattern マッチパターンを指定する。
'  conversion   変換方法

    Dim posi        As Long '文字位置
    Dim textLength  As Long '文字数

    Debug.Assert targetRange.Count = 1  '複数セル不可

    '数式、文字列型以外の値は対象外
    If targetRange.HasFormula Then Exit Sub
    If VarType(targetRange.Value) <> vbString Then Exit Sub

    '文字の変換
    textLength = targetRange.Characters.Count
    For posi = 1 To textLength
        With targetRange.Characters(posi, 1)
            If .Text Like matchPattern Then
                .Text = StrConv(.Text, conversion)
            End If
        End With
    Next

End Sub

 
基本的な考えてして、作成するプログラムは将来、自分ではない第三者がメンテナンスすると考えて作成しましょう。
例えば、Mougで、コードが開示されますが、コードを見て、処理内容が理解できないコードを見かけると思います。逆に、何をしているか、すぐ分るコードも見かけますよね。
後者のほうが、コードの問題点・修正箇所が短時間で可能なのは理解できると思います。
 
私なら、原則として次のことを意識します。
・メンテナンス性を第一に。
・可読性を重視
・第三者が読んだとき、コードの意図が理解できる。
 
上記を具体的に実現するには、
・プロシージャは役割は一つのみ。(複数の機能にしない)
・「ユーザーの操作」と「実際の処理」を分割する。
・単体テストを重視
・メゾット名は「動詞」で始める。
・ネーミングが重要。内容が直感できるネーミングを心がける。
 
ほかにも、ありますが、重要なことのみ上げました。
(全部書くと一冊の本になる)
 
◯メゾット名は「動詞」+「名詞」
VBAのコードウインドウには、右上にコンボボックスがありますね。これをクリックすると、プロシージャのリストが出ます。このとき、プロシージャのリストがABC順に並びます。「動詞」+「名詞」にすると、リストはABC順に並びますから、プロシージャはよく似た機能が並ぶことになります。
(メゾットとは〇〇を△△する。つまり動詞です)
 
そして、コード作成の際、プロシージャ名がうるおぼえでも、とりあえず「Ctrl」+「スペース」でオートコンプリートが働きますので、conv と途中までキー入力すれば
  ConvertSelecton
  ConvertSingleCell
と出ますから、あとは「Tab」キー。そしてその後 引数も出ますし。
 
【エクセルVBA】最初っから知っておきたいVBEのショートカットキーまとめ
https://tonari-it.com/excel-vba-vbe-shortcut-key-list/
 
◯単体テスト
プロシージャは単一責任の原則で作成しましょう。簡単にいうと、プロシージャは複数の機能にしない。一つの処理のみとする
コードはできるだけ行数を短くする。コードが長ほと複雑で理解が困難となり。バグの原因となります。複雑になってきたら、分割を検討しましょう。分割すると、バグや修正時に、変更範囲・影響が狭くなるので、メンテナンスが行いやすくなります。
そして、プロシージャのみ単体でテストが重要です。パラメータを変更しながら、テストを行い、バグを排除してプロシージャ単体で品質を確保します。
 
提示のサンプルコードの例にすると ConvertSelectonCell は ConvertSelecton から呼び出してます。これコードを分割せずに一つのプロシージャに出来ますが、そうすると、ネストが深くなり、変数も多くなり、理解が困難になるでしょう。分割すると、理解しやすく、バクも出にくいコードになります。
メンテナンス製も上がり、XMLスプレッドシート形式への変更する際、どこを変更箇所すればよいか明確になります。
 
ところで、サロゲートペアですが、目的はJw_cadとのことですね。建築用CADとして名前は知ってますが、Jw_cadはサロゲートペア等に対応しているのでしょうか。サロゲートペアは歴史が浅く、とくに建築分野では、特殊文字の必要性が低く、非対応の可能性があります。もし、𩸽、𠮟、🙇‍♂️、🙅‍♂️の等の文字が、Jw_cadで扱えないなら、出力されることも無いので、考える必要は無いと思うのですが。
 
 
さて、O.Mさんの提示コードで、気になる箇所あります。
 
提示コートにエラートラップをしている理由はなぜでしょうか。エラーは、エラー発生しないコードの作成が鉄則です。エラートラップすると、バグをもみ消すことになり、誤変換のままになります。そして誤変換に、気づくことも出来ません。品質の高いコードの作成には、単体テストで早期にバクに気づくことが重要です。
 
あと、下記のコードの意図は何でしょう。
  Application.ScreenUpdating
  Application.EnableEvents
  Application.Calculation
 

投稿日時: 23/12/11 11:02:15
投稿者: O.M

MMYSさん
      
丁寧にありがとうございます。
全体設計についてあまり深く考えておらず、全然思い浮かばなかった考え方でした。
ありがとうございます。
      
また、上部表示のコンボボックスですがWorksheet_Changeイベントのコードをつくる際に
少し触ったことがある程度で基本的に全く活用をしておらず、
使用方法など考えたことも有りませんでした、ありがとうございます。
  
教えていただいたことをきちんと活用できるように考えて使用するようにしたいと思います。
※自分では理解したつもりになっているのに全然理解できていないことも多いので、
わかっていなさそうだなと思ったら、お手数ですがご指摘いただけると嬉しいです。
      

引用:
ところで、サロゲートペアですが、目的はJw_cadとのことですね。建築用CADとして名前は知ってますが、Jw_cadはサロゲートペア等に対応しているのでしょうか。サロゲートペアは歴史が浅く、とくに建築分野では、特殊文字の必要性が低く、非対応の可能性があります。もし、𩸽、𠮟、🙇‍♂️、🙅‍♂️の等の文字が、Jw_cadで扱えないなら、出力されることも無いので、考える必要は無いと思うのですが。

  
ご指摘ありがとうございます。
申し訳有りません、メインの使用目的しか書いていませんでした。
      
実際の使用方法としてはアドインにしていましてユーザー設定のツールバーに表示させて、
Jwに貼り付けする目的の場合以外にもそこそこ使用しています。
そのため、対応できたほうが良いかと考えての処理でした。
    
      
引用:
さて、O.Mさんの提示コードで、気になる箇所あります。
   
提示コートにエラートラップをしている理由はなぜでしょうか。エラーは、エラー発生しないコードの作成が鉄則です。エラートラップすると、バグをもみ消すことになり、誤変換のままになります。そして誤変換に、気づくことも出来ません。品質の高いコードの作成には、単体テストで早期にバクに気づくことが重要です。
 

   
      
現在の使用方法としては作業効率UPのために個人的に使用しています。
※チェンジイベントや書式設定、式等、考慮することが多いのでどうかなぁと考えて
自分の使用だけの使用に留めていました。
※コード作成時・動作確認時にはエラートラップを外していて確認しています。
     
将来的に社内活用できたらいいかも…とぼんやり考え、
配布するならわからない方はいきなりVBE画面が出てきても困るだろうし、
エラーが出るようなデータはスルーして処理なしで済ませたほうがいだろうという意図で付けてました。
     
今回の部分的的な文字色やサロゲートペアの問題を認識し、
いろいろ知らないことが多すぎて怖かったので、個人使用のみに考えを改めましたが、
そのままにしてしまっていました。
     
ご指摘いただいたようにバグに気がつけるようにコードを消させていただきます。
     
 
引用:
あと、下記のコードの意図は何でしょう。
  Application.ScreenUpdating
  Application.EnableEvents
  Application.Calculation

  
      
処理速度UPのためという認識でした。
https://excel-ubara.com/excelvba5/EXCELVBA210.html
      
アドインで色々なエクセルBOOKで使用するので、
付けておいたほうが無難かなといったゆるーい考えでつけました。
   
ちなみにコピペで貼り付け何も考えずコードを付けてしまっていたのですが、
最後に再開する際は逆順のほほうがいいだろうと掲示板に投稿した後で
見返してきがつきましたがそのままにしていました。

回答
投稿日時: 23/12/11 18:17:12
投稿者: MMYS

O.M さんの引用:

配布するならわからない方はいきなりVBE画面が出てきても困るだろうし、
エラーが出るようなデータはスルーして処理なしで済ませたほうがいだろうという意図で付けてました。

しっかりテストして品質を確保すれば本番運用でVBE画面になることは通常ありません。また通常使用で考えられるエラーには対策コードを組み込むのが普通です。
エラートラップが必要なケースは、想定外の動作。例えばファイル操作中にユーザーがUSBメモリを抜いた。ネットワークが切れた。などの例外処理などでしょうか。
 
 
O.M さんの引用:

処理速度UPのためという認識でした。

それ自体は問題ありません。問題は、処理の途中で設定と解除を繰り返していることです。画面描写をすると速度低下につながるので描写停止しているのに、解除と禁止を繰り返したら、解除で画面描写が行われ描写に時間を取られてしまいます。それでは意味がありませんよね。
リンク先の説明でも開始時に設定。終了時に戻す。と説明されています。
 

投稿日時: 23/12/11 22:57:22
投稿者: O.M

引用:
しっかりテストして品質を確保すれば本番運用でVBE画面になることは通常ありません。また通常使用で考えられるエラーには対策コードを組み込むのが普通です。
エラートラップが必要なケースは、想定外の動作。例えばファイル操作中にユーザーがUSBメモリを抜いた。ネットワークが切れた。などの例外処理などでしょうか。

 
  
すみません、自分の知識不足で”通常ありえない”状態にしてしまうことがそこそこありまして…。
いろいろなパターンを試して完璧なつもりでいたのにそれは勘違いで、
実際使用していくとエラーが出るという経験がありまして、
私の場合は”自分が想定していなかった間違いはあるもの”という認識でした。
     
きちんとできる方はできるのでしょうが、自分ではなかなかできなくて…。
完璧にしたつもりで全然間違っていることがあるので、
ちゃんとできているのかできていないのかも判別つかず、逃げでつけてしまうことがあります。
     
  
引用:
それ自体は問題ありません。問題は、処理の途中で設定と解除を繰り返していることです。画面描写をすると速度低下につながるので描写停止しているのに、解除と禁止を繰り返したら、解除で画面描写が行われ描写に時間を取られてしまいます。それでは意味がありませんよね。
リンク先の説明でも開始時に設定。終了時に戻す。と説明されています。

 
  
  
投稿日時: 23/12/09 01:27:11のコードを見返したのですが、
開始時に設定、修理時に戻す処理になっていると思っておりまして、
どこが違うかわからなかったです、すみません。
     
処理を半角→全角、全角→半角、大文字小文字の3つの変換に分けていまして、
それを1つにまとめて記載しているため私のごちゃごちゃとした見難いコードの書き方のせいで、
1つのコードに見えてしまったのかなと思ってしまいました。
    
そうではない場合ですが、
指摘をいただいて何回か見返しても間違っている部分を理解できておらず、
自力での理解が難しい状態だと思いますので、
お手数ですが具体的に間違っている部分を教えていただけるとありがたいです。
(時間をおいて頭が切り替わったらあっさり気が付く場合もあるので後日またみかえしてはみます)
よろしくお願いいたします。
     
     
大まかな流れとしては下記のような流れのつもりでして、
最初と最後に処理をしているつもりでした。
※複数シート選択禁止のSheetCountCheckがすべてに共通なのでまとめて1つに記載しました。
     
     
'全→半角 設定
Sub ZenHanHenkan()
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
 
'複数シート選択禁止のSheetCountCheck呼び出し ※停止・再開の記述はなし
'処理方法指定
'設定のワイルドカード文字結合のChangeTextMakeを呼び出し ※停止・再開の記述はなし
'セルのループ処理開始
’半角全角・全角半角共通処理のZenHanConvertを呼び出し(記号以外) ※停止・再開の記述はなし
’半角全角・全角半角共通処理のZenHanConvertを呼び出し(記号)   ※停止・再開の記述はなし
’セルのループ処理終了
 
 
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

     
  
'半→全角 設定
Sub HanZenHenkan()
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
 
'複数シート選択禁止のSheetCountCheck呼び出し ※停止・再開の記述はなし
'処理方法指定
'設定のワイルドカード文字結合のChangeTextMakeを呼び出し ※停止・再開の記述はなし
'セルのループ処理開始
’半角全角・全角半角共通処理のZenHanConvertを呼び出し(記号以外) ※停止・再開の記述はなし
’半角全角・全角半角共通処理のZenHanConvertを呼び出し(記号)   ※停止・再開の記述はなし
’セルのループ処理終了
 
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End sub

    
     
’【選択セルの文字の大文字小文字変換】
Sub DaiSyouHenkan()
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
 
'複数シート選択禁止のSheetCountCheck呼び出し ※停止・再開の記述はなし
'処理方法指定
'セルのループ処理開始
'大文字小文字変換のProUpLowConvert呼び出し  ※停止・再開の記述はなし
'セルのループ処理終了
 
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

回答
投稿日時: 23/12/12 23:25:09
投稿者: MMYS

O.M さんの引用:

実際使用していくとエラーが出るという経験がありまして、
私の場合は”自分が想定していなかった間違いはあるもの”という認識でした。
<中略>
ちゃんとできているのかできていないのかも判別つかず、逃げでつけてしまうことがあります。

プロであっても、完全に防ぐのは無理です。それでもバグの隠蔽はしません。なぜなら、バグは早期に気づくほど、修正が簡単で、発見が遅いほど大きな問題になるからです。
 
たとえば、O.M さんが作成したコードは、同僚の方がお使いになられると思います。同僚の方は、業務効率化を求めておりますが、O.M さんはプロではないのは承知でしょう。プロでない方に完璧なコードは求めてないと思いますが。仮にバグで停止しても、それは些細な問題でとどまります。しかし、バグを隠蔽するとだれも気づかないので、そのまま業務は遂行。最終的には、お客さんの元て発覚。顧客からの信用につながるかも知れません。
 
実際の現場でバグが出るのは避けられないと思います。バグが出でる事は、むしろ貴重な経験だと思います。なぜバグを発見出来なかったのか。どんなテストをすれば、発見できたのか。と考えますよね。それがスキルアップに繋がります。
 
なお、実務ではバグを完全に防ぐのは困難なため、想定外のバグに備えて、例外処理を組み込みますが、今回の例では、大げさすぎると思います。(エラートラップでエラーログを作成や、エラー発生前の状態に戻すロールバック。ユーザーにエラー発生を報告。など)
 
 
O.M さんの引用:

お手数ですが具体的に間違っている部分を教えていただけるとありがたいです。

申し訳ありません。よく確認したら、1回かぎりですので、間違いではありません。
ただし、提示の最新コードは、コードの意図がまったく理解できません。提示のコードではバグが混入するのではと心配になります。
 
 
なお、前回の提示コードに一部誤りがありました。申し訳ありません。正しくは下記となります。また、一部、変更してあります。
 
ユーザーフォーム
Option Explicit

Private Sub CommandButton1_Click()

    Dim convertData(1 To 6) As myConvert
    Dim cb  As MSForms.checkBox
    Dim selectionRange As Range
    Dim i   As Byte

    convertData(1).matchPattern = "[0-9]"
    convertData(1).conversion = vbNarrow
    convertData(2).matchPattern = "[A-Z,a-z]"
    convertData(2).conversion = vbNarrow
    convertData(3).matchPattern = "[ア-ン]"
    convertData(3).conversion = vbNarrow

    convertData(4).matchPattern = "[0-9]"
    convertData(4).conversion = vbWide
    convertData(5).matchPattern = "[A-Z,a-z]"
    convertData(5).conversion = vbWide
    convertData(6).matchPattern = "[ア-ン]"
    convertData(6).conversion = vbWide
  
    'チェックボックスの値取得
    For i = LBound(convertData) To UBound(convertData)
        Set cb = Me.Controls("CheckBox" & i)
        convertData(i).checkboxValue = cb.Value
    Next
    Set cb = Nothing

    '選択範囲のセル値を変換
    Set selectionRange = Selection
    ConvertSelecton selectionRange, convertData '選択範囲を変換
    Set selectionRange = Nothing

End Sub

 
標準モジュール
Option Explicit

Type myConvert
    checkboxValue   As Boolean      'チェックボックスの値
    matchPattern    As String       'マッチパターン
    conversion      As VbStrConv    '変換方法
End Type


Sub testConvertSelecton()
'単体テスト
  Dim c(0) As myConvert
  c(0).checkboxValue = True
  c(0).matchPattern = "[0-9]"
  c(0).conversion = vbNarrow
  ConvertSelecton Range("A1:A10"), c
End Sub

Public Sub ConvertSelecton(selectionRange As Range, convertData() As myConvert)
'選択範囲のセル値を指定にもとづいて変換します。
'  selectionRange  セル範囲を指定する
'  convertData     変換データを配列で指定する

    Dim TargetCell  As Range
    Dim checkBox    As Boolean
    Dim ChangeText  As String
    Dim conversion  As VbStrConv
    Dim i   As Integer
  
    For Each TargetCell In selectionRange

        For i = LBound(convertData) To UBound(convertData)
            '配列から値を取得
            With convertData(i)
                checkBox = .checkboxValue   'チェックボックスの値
                ChangeText = .matchPattern  'マッチパターン
                conversion = .conversion    '変換方法
            End With

            If checkBox Then    'checkboxがオンなら
                '全角または半角の変換
                ConvertSelectonCell TargetCell, ChangeText, conversion
            End If

        Next
    Next

End Sub


Sub testConvertSelectonCell()
'単体テスト
  ConvertSelectonCell Range("A1"), "[0-9]", vbNarrow
 'ConvertSelectonCell Range("A2"), "[A-Z,a-z]", vbNarrow
 'ConvertSelectonCell Range("A3"), "[ア-ン]", vbNarrow
 'ConvertSelectonCell Range("A4"), "[0-9]", vbWide
 'ConvertSelectonCell Range("A5"), "[A-Z,a-z]", vbWide
 'ConvertSelectonCell Range("A6"), "[ア-ン]", vbWide
End Sub

Private Sub ConvertSelectonCell(targetRange As Range, matchPattern As String, conversion As VbStrConv)
'全角または半角の変換を行います
'  targetRange  変換対象のRangeオブジェクト
'  matchPattern マッチパターンを指定する。
'  conversion   変換方法

    Dim char    As Characters   '1文字
    Dim posi        As Long     '文字位置
    Dim textLength  As Long     '文字数

    Debug.Assert targetRange.Count = 1  '複数セル不可

    '数式、文字列型以外の値は対象外
    If targetRange.HasFormula Then Exit Sub
    If VarType(targetRange.Value) <> vbString Then Exit Sub

    '文字の変換
    textLength = targetRange.Characters.Count
    For posi = 1 To textLength
        Set char = targetRange.Characters(posi, 1)
        If char.Text Like matchPattern Then
            char.Text = StrConv(char.Text, conversion)
        End If
    Next
    Set char = Nothing

End Sub

投稿日時: 23/12/13 03:03:21
投稿者: O.M

なお、実務ではバグを完全に防ぐのは困難なため、想定外のバグに備えて、例外処理を組み込みますが、今回の例では、大げさすぎると思います。(エラートラップでエラーログを作成や、エラー発生前の状態に戻すロールバック。ユーザーにエラー発生を報告。など)

 
  
アドインにしていたため、将来社内利用するとしたらどんなBOOKで使うかもわからないし、
excelバージョンも何になるのかわからないと思い範囲を広めにとってました。
  
※今回の件で何があるのか自分にはわからないことだらけだと知ったため、
自分専用にすると決めたのでエラートラップは消しました。
  
  
ただし、提示の最新コードは、コードの意図がまったく理解できません。提示のコードではバグが混入するのではと心配になります。

 
  
バグ対策、処理工程を減らす、先頭文字を大文字、全角半角対策を必死に考えた結果ごちゃごちゃしてしまいました。
  
変換するセルを範囲選択→アドインクリック→ユーザーフォームを起動
→変換条件をチェックボックスで選択→実行というのが実際の流れでして、
  
例えば半角変換の場合、変換対象として
数字の変換、英字の変換、カタカナの変換、記号の変換(前述の3種以外)の
チェックボックスがあり、ワイルドカードで判別する際に、
  
全てチェックの場合は *
  
記号以外の場合は文字結合したワイルドカード
たとえば数字だけなら、[0-9]
数字と英字なら[0-9,A-Z,a-z]
数字と英字とカタカナなら[0-9,A-Z,a-z,ァ-ヶー]
数字とカタカナなら[0-9,ァ-ヶー]
となるように文字を組み合わせて、
  
  '全変換の場合
  If Kazu = True And Eizi = True And Kana = True And Kigo = True Then
    ChangeText = "*"
  Else
    '数字変換
    If Kazu = True Then ChangeTextMake ChangeText, "0-9"
    '英字変換
    If Eizi = True Then ChangeTextMake ChangeText, "A-Z,a-z"
    'カタカナ変換
    If Kana = True Then ChangeTextMake ChangeText, "ァ-ヶー"
    If ChangeText <> "" Then
      ChangeText = "[" & ChangeText & "]"
    End If
  End If

  
'ワイルドカード文字の結合
Private Function ChangeTextMake(ChangeText As String, str As String)
     If ChangeText = "" Then
        ChangeText = str
      Else
        ChangeText = ChangeText & "," & str
      End If
End Function

 
  
組み合わせたワイルドカードが""以外になったら変換処理
!を使用した除外のワイルドカード一緒には処理できない(と思ってるんですが違ったらすみません)ので
記号変換の場合は別に変換としています。
  
”かーど”と”カード”の文字があった場合、ーはどうするかに関しては
カタカナで使用されている率のほうが高いだろうと考えカタカナのほうの変換に入れ込んでいます。
   
 '変換
  For Each rn In Selection.Cells
    '記号のみ以外の変換
    If ChangeText <> "" Then ZenHanConvert rn, ChangeText, conversion
    '記号のみの変換
    If Kigo = True Then ZenHanConvert rn, "[!0-9,A-Z,a-z,ァ-ヶー]", conversion
  Next

  
自分が見た範囲ではサロゲートペア文字や4バイトを超えるマルチバイト文字は
rn.Characters(i, 1).textで見ると?を含む複数文字の文字化けした文字列になり、
手を加えたら不具合が出るようだったので、
変換前が?や?なら変換
変換前が?や?ではなく、変換後も?や?を含まないなら変換
という判別方法でエラーを排除しています。
  
(文字化けしている文字ですが、変換前と同じ文字を変換後に戻せばエクセルのシート上で
元の文字にもどるのでは?と思いためしたのですが、
同じ文字を戻しても不具合がでるようなので一切いじれないという認識になっています)
  
If (bfstr = "?" Or bfstr = "?") Or (bfstr <> "?" And bfstr <> "?" And InStr(str, "?") = 0 And InStr(str, "?") = 0) Then

 
  
  
カタカナの半角変換の場合は、ガ→ガとなり、ガの1文字がカと゛の2文字に変換され、
半角のガを全角変換するとカと゛の2文字になり、ガに戻らない状態になるため、
  
「2文字まとめて変換したら1文字になる文字があった場合、
前の文字に1文字になった文字を入れて後ろの文字は""にする」
  
ということにして対策しています。
具体例としては、カと゛の2文字を全角にした場合、カの文字位置にガを入れて、゛の文字位置は""にしています。
※2文字なのでカと゛で文字色やフォントが異なる場合も想定されますが、
あまり考えられないパターンだろうし、
カタカナのほうの書式に統一するのが間違いが少ないと思い、前の文字を優先にしました。
  
            If i < j And Len(StrConv(bfstr & rn.Characters(i + 1, 1).Text, vbWide)) = 1 Then
              .Text = StrConv(bfstr & rn.Characters(i + 1, 1).Text, vbWide)
              rn.Characters(i + 1, 1).Text = ""
            Else
              .Text = str
            End If

 
 
  
  
大文字小文字変換に関しては?も?大文字にも小文字にも変換されないので、
半角変換のサロゲートペア文字や、4バイトを超えるマルチバイト文字の変換に際してのエラー対策にある
(bfstr = "?" Or bfstr = "?")
 
の部分は抜きました。
また、""の文字列をいじってしまうと不具合が出たのでその部分の対策を足しています。
If InStr(str, "?") = 0 And InStr(str, "?") = 0 And bfstr <> "" Then
 
  
先頭文字大文字変換する際には、いったん文章をつくらないとどこが先頭文字かわからないのですが、
半角変換のサロゲートペア文字や、4バイトを超えるマルチバイト文字がある場合、
文字化け(「🙇‍♂️」が「???♂?」になる等)をするため処理ができなかったので、
  
サロゲートペア文字や、4バイトを超えるマルチバイト文字を”あ”にいったん置き換えて変換して
先頭の大文字をだして、文字化けする"あ"に置き換えた部分以外(true)の位置に
変換後の文字を戻しています。
  

TEST🙇‍♂️ CASE
  
TEST???♂? CASE
のような感じになるのですが
???♂?の部分の文字列はいじると不具合がでるので
  
いったん仮のデータを作り
TESTあああああ CASE
としてから変換し
Tsestあああああ Case
とし、
  
元のデータの???♂?以外の部分を変換して
Tsest???♂? Case
となるようにすると、エクセルのシート上で
Tsest🙇‍♂️ Case
になるので変換できたという認識です。
 
 
うまく説明できないのですが補足で書きますと、
  
セルのtextが、"TEST???♂? CASE"で、
Charactersで一文字ずつtextをみると、
最初の?のtextは"???♂?"
♂のtextも"???♂?"
といったように、Charactersのtextが1文字ではなく全部"???♂?"になっていて、
"???♂?"になっているなら"???♂?"を戻せば元の文字になるのかと
試してみたら不具合が出たので、手を加えてはいけない場所と考え処理をしないようにしました。
 
  
 
   For i = j To 1 Step -1
      With rn.Characters(i, 1)
        bfstr = .Text
        str = StrConv(bfstr, conversion)
        If InStr(str, "?") = 0 And InStr(str, "?") = 0 And bfstr <> "" Then
          Str2(1, i) = str
          Str2(2, i) = True
        Else
          Str2(1, i) = "あ"
          Str2(2, i) = False
        End If
        Str3 = Str2(1, i) & Str3
      End With
    Next
    Str3 = StrConv(Str3, vbProperCase)
    For i = j To 1 Step -1
      With rn.Characters(i, 1)
        If Str2(2, i) = True Then
          .Text = Mid(Str3, i, 1)
        End If
      End With
    Next

回答
投稿日時: 23/12/13 22:24:53
投稿者: MMYS

O.M さんの引用:

バグ対策、処理工程を減らす、先頭文字を大文字、全角半角対策を必死に考えた結果ごちゃごちゃしてしまいました。

どのように、コーディングするかは、O.Mさんの自由です。お好きな方法でどうぞ。
 
ただ、上記の状態では、リファクタリングを検討されたほうが、良いでは、と思います。
なお、リファクタリングとは下記のように理解しやすくするため、変数名を整理したりして、可読性を向上し、変更に強いコートにする目的の改修です。
 
 
■リファクタ前
Public Function ZenHanConvert(rn As Range, ChangeText As String, conversion As Variant)
  Dim i As Long, j As Long
  '数式、文字列型以外の値は対象外
  If rn.HasFormula Then Exit Function
  If VarType(rn.Value) <> vbString Then Exit Function
  '文字の変換
  j = rn.Characters.Count
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For i = 1 To j
    With rn.Characters(i, 1)
      If .Text Like ChangeText Then
          .Text = StrConv(.Text, conversion)
      End If
    End With
  Next i
ErrHndl:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Function

■リファクタ後
Private Sub ConvertSelectonCell(targetRange As Range, matchPattern As String, conversion As VbStrConv)
'全角または半角の変換を行います
'  targetRange  変換対象のRangeオブジェクト
'  matchPattern マッチパターンを指定する。
'  conversion   変換方法

    Dim char    As Characters   '1文字
    Dim posi        As Long     '文字位置
    Dim textLength  As Long     '文字数

    Debug.Assert targetRange.Count = 1  '複数セル不可

    '数式、文字列型以外の値は対象外
    If targetRange.HasFormula Then Exit Sub
    If VarType(targetRange.Value) <> vbString Then Exit Sub

    '文字の変換
    textLength = targetRange.Characters.Count
    For posi = 1 To textLength
        Set char = targetRange.Characters(posi, 1)
        If char.Text Like matchPattern Then
            char.Text = StrConv(char.Text, conversion)
        End If
    Next
    Set char = Nothing

End Sub

補足解説。
コードの先頭に
    Debug.Assert targetRange.Count = 1 '複数セル不可
とありますが、このサブルーチンのFor Each 内で呼び出しが前提のため、targetRangeの引数はは1セルのみです。 ここで停止した場合、呼び出し元でバグです。バグは早期に発見できるほど、修正が容易たやすく、またtargetRangeは1セルですよとコードで掲示する意図もあります。
 

投稿日時: 24/01/10 12:54:15
投稿者: O.M

MMYSさん
 
いろいろとありがとうございます。
書きやすさ(短さ)が優先気味になっていました、申し訳ございません。
理解不足に加え体調不良等ありまだかかりそうです、
私のせいでスレッドも伸びてしまっているのである程度まとまってから再度質問させていただきたいと
思っています。

投稿日時: 24/02/08 19:52:44
投稿者: O.M

申し訳ございません。
業務で使用しているExcelVBAで、64bitのExcelになりエラーとなるようになったものが大量にあり
そちらの修正にかかりきりになってしまっております。
長々と申し訳ないのですが、まだしばらくお時間ください。

トピックに返信