Excel VBA質問箱 IV

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

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


9812 / 13646 ツリー ←次へ | 前へ→

【25322】文字の置き換え hiroshi 05/5/28(土) 15:01 質問[未読]
【25336】Re:文字の置き換え ichinose 05/5/28(土) 21:33 発言[未読]
【25345】Re:文字の置き換え 一箇所訂正 ichinose 05/5/29(日) 9:28 発言[未読]
【25359】Re:文字の置き換え 一箇所訂正 hiroshi 05/5/29(日) 15:49 お礼[未読]
【25340】Re:文字の置き換え Hirofumi 05/5/29(日) 1:18 回答[未読]
【25342】Re:文字の置き換え Hirofumi 05/5/29(日) 8:19 回答[未読]
【25349】Re:文字の置き換え Hirofumi 05/5/29(日) 10:35 回答[未読]
【25360】Re:文字の置き換え hiroshi 05/5/29(日) 15:50 お礼[未読]

【25322】文字の置き換え
質問  hiroshi E-MAIL  - 05/5/28(土) 15:01 -

引用なし
パスワード
   はじめまして。ExcelVBAの質問させてください。
質問1
ASC関数を使い全角2バイトを半角1バイトに変換したあと半角変換できない文字は「-」に置き換える。
11大阪府11→11-11
質問2
半角変換できない文字の後に文字が続かない場合は省略する。
11大阪府→11
質問3
「-」に置き換えた結果「-」が連続する場合は「-」をひとつ省略する。
11大阪府-11→11-11

実際には何万というレコードが有り一番上から順番に処理していくような方法にしたいと思っています。
よろしくお願い致します。

【25336】Re:文字の置き換え
発言  ichinose  - 05/5/28(土) 21:33 -

引用なし
パスワード
   ▼hiroshi さん:
こんばんは。

>はじめまして。ExcelVBAの質問させてください。
>質問1
>ASC関数を使い全角2バイトを半角1バイトに変換したあと半角変換できない文字は「-」に置き換える。
>11大阪府11→11-11
>質問2
>半角変換できない文字の後に文字が続かない場合は省略する。
>11大阪府→11
>質問3
>「-」に置き換えた結果「-」が連続する場合は「-」をひとつ省略する。
>11大阪府-11→11-11
>
>実際には何万というレコードが有り一番上から順番に処理していくような方法にしたいと思っています。
>よろしくお願い致します。

非常にわかりやすいご質問の記述ですね!!

'============================================================
Dim regEx As Object
Sub test()
  Set regEx = CreateObject("VBScript.RegExp")
  変換文字列 = "11大阪府-11"
  MsgBox get_replace(StrConv(変換文字列, vbNarrow), "-")
  変換文字列 = "123---大阪府-11-123---"
  MsgBox get_replace(StrConv(変換文字列, vbNarrow), "-")
  Set regEx = Nothing
End Sub
'=====================================================================
Function get_replace(mystr, cnvstr, Optional ByVal short As Boolean = True) As String
'全角文字を指定文字に変換する
'input mystr----変換対象文字列
'    cnvstr---検索文字
'    short----省略可---True---短縮処理と末尾処理を行う
'output get_replace---変換された文字列
  Dim chkidx As Long
  Dim get_replacewk As String
  chkidx = 1
  get_replacewk = ""
  Do While chkidx <= Len(mystr)
   If LenB(StrConv(Mid(mystr, chkidx, 1), vbFromUnicode)) = 2 Then
    get_replacewk = get_replacewk & cnvstr
   Else
    get_replacewk = get_replacewk & Mid(mystr, chkidx, 1)
    End If
   chkidx = chkidx + 1
   Loop
  If short = True Then
   Set regEx = CreateObject("VBScript.RegExp")
   regEx.Pattern = "\" & cnvstr & "{2,}"
   regEx.IgnoreCase = True
   Do
    get_replacewk = regEx.Replace(get_replacewk, cnvstr)
    Loop While regEx.test(get_replacewk)
   regEx.Pattern = "\" & cnvstr & "{1,}$"
   Do
    get_replacewk = regEx.Replace(get_replacewk, "")
    Loop While regEx.test(get_replacewk)
   get_replace = get_replacewk
  Else
   get_replace = get_replacewk
   End If
End Function

プロシジャーtestは一例ですから、このプロシジャーに一万行の
ループ処理と言う事になりますが・・・。

確認してみて下さい。

【25340】Re:文字の置き換え
回答  Hirofumi  - 05/5/29(日) 1:18 -

引用なし
パスワード
   面白そうだから作って見たけど
何万行のオーダーだといくら時間が掛かるか?

Option Explicit

Public Sub Test2()

  '11大阪府11
  MsgBox "11大阪府11 → " & GetPurpose("11大阪府11")
  '11大阪府
  MsgBox "11大阪府 → " & GetPurpose("11大阪府")
  '11大阪府-11
  MsgBox "11大阪府-11 → " & GetPurpose("11大阪府-11")
  
End Sub

Public Function GetPurpose(ByVal strMark As String) As String

  Dim i As Long
  Dim lngIndex As Long
  Dim bytResult() As Byte
  Dim strLetter As String
  Dim bytLetter() As Byte
  Dim blnWide As Boolean
  Dim strReplace As String
  Dim bytReplace() As Byte
  
  If strMark = "" Then
    Exit Function
  End If
  
  strMark = StrConv(strMark, vbNarrow)
  strReplace = StrConv("-", vbFromUnicode)
  bytReplace = strReplace
  
  For i = 1 To Len(strMark)
    strLetter = StrConv(Mid(strMark, i, 1), vbFromUnicode)
    If LenB(strLetter) <> 2 Then
      If strLetter <> strReplace Then
        blnWide = False
        bytLetter = strLetter
        ReDim Preserve bytResult(lngIndex)
        bytResult(lngIndex) = bytLetter(0)
        lngIndex = lngIndex + 1
      End If
    Else
      If Not blnWide Then
        blnWide = True
        ReDim Preserve bytResult(lngIndex)
        bytResult(lngIndex) = bytReplace(0)
        lngIndex = lngIndex + 1
      End If
    End If
  Next i
      
  If blnWide Then
    ReDim Preserve bytResult(lngIndex - 2)
  End If
  
  GetPurpose = StrConv(CStr(bytResult), vbUnicode)
  
End Function

【25342】Re:文字の置き換え
回答  Hirofumi  - 05/5/29(日) 8:19 -

引用なし
パスワード
   半角に成る文字が1つも無い場合、エラーに成るので修正しました

Public Function GetPurpose(ByVal strMark As String) As String

  Dim i As Long
  Dim lngIndex As Long
  Dim bytResult() As Byte
  Dim strLetter As String
  Dim bytLetter() As Byte
  Dim blnWide As Boolean
  Dim strReplace As String
  Dim bytReplace() As Byte
  
  If strMark = "" Then
    Exit Function
  End If
  
  strMark = StrConv(strMark, vbNarrow)
  strReplace = StrConv("-", vbFromUnicode)
  bytReplace = strReplace
  
  For i = 1 To Len(strMark)
    strLetter = StrConv(Mid(strMark, i, 1), vbFromUnicode)
    If LenB(strLetter) <> 2 And strLetter <> strReplace Then
      blnWide = False
      bytLetter = strLetter
      ReDim Preserve bytResult(lngIndex)
      bytResult(lngIndex) = bytLetter(0)
      lngIndex = lngIndex + 1
    Else
      If Not blnWide Then
        blnWide = True
        ReDim Preserve bytResult(lngIndex)
        bytResult(lngIndex) = bytReplace(0)
        lngIndex = lngIndex + 1
      End If
    End If
  Next i
      
  If blnWide Then
    lngIndex = lngIndex - 2
  Else
    lngIndex = lngIndex - 1
  End If
  
  If lngIndex > -1 Then
    ReDim Preserve bytResult(lngIndex)
    GetPurpose = StrConv(bytResult, vbUnicode)
  End If
  
End Function

【25345】Re:文字の置き換え 一箇所訂正
発言  ichinose  - 05/5/29(日) 9:28 -

引用なし
パスワード
   訂正して下さい

>>はじめまして。ExcelVBAの質問させてください。
>>質問1
>>ASC関数を使い全角2バイトを半角1バイトに変換したあと半角変換できない文字は「-」に置き換える。
>>11大阪府11→11-11
>>質問2
>>半角変換できない文字の後に文字が続かない場合は省略する。
>>11大阪府→11
>>質問3
>>「-」に置き換えた結果「-」が連続する場合は「-」をひとつ省略する。
>>11大阪府-11→11-11
>>
>>実際には何万というレコードが有り一番上から順番に処理していくような方法にしたいと思っています。
>>よろしくお願い致します。
>
>非常にわかりやすいご質問の記述ですね!!
>
>'============================================================
>Dim regEx As Object
>Sub test()
>  Set regEx = CreateObject("VBScript.RegExp")
>  変換文字列 = "11大阪府-11"
>  MsgBox get_replace(StrConv(変換文字列, vbNarrow), "-")
>  変換文字列 = "123---大阪府-11-123---"
>  MsgBox get_replace(StrConv(変換文字列, vbNarrow), "-")
>  Set regEx = Nothing
>End Sub
>'=====================================================================
>Function get_replace(mystr, cnvstr, Optional ByVal short As Boolean = True) As String
>'全角文字を指定文字に変換する
>'input mystr----変換対象文字列
>'    cnvstr---検索文字
>'    short----省略可---True---短縮処理と末尾処理を行う
>'output get_replace---変換された文字列
>  Dim chkidx As Long
>  Dim get_replacewk As String
>  chkidx = 1
>  get_replacewk = ""
>  Do While chkidx <= Len(mystr)
>   If LenB(StrConv(Mid(mystr, chkidx, 1), vbFromUnicode)) = 2 Then
>    get_replacewk = get_replacewk & cnvstr
>   Else
>    get_replacewk = get_replacewk & Mid(mystr, chkidx, 1)
>    End If
>   chkidx = chkidx + 1
>   Loop
>  If short = True Then
'   Set regEx = CreateObject("VBScript.RegExp") ←削除してください
>   regEx.Pattern = "\" & cnvstr & "{2,}"
>   regEx.IgnoreCase = True
>   Do
>    get_replacewk = regEx.Replace(get_replacewk, cnvstr)
>    Loop While regEx.test(get_replacewk)
>   regEx.Pattern = "\" & cnvstr & "{1,}$"
>   Do
>    get_replacewk = regEx.Replace(get_replacewk, "")
>    Loop While regEx.test(get_replacewk)
>   get_replace = get_replacewk
>  Else
>   get_replace = get_replacewk
>   End If
>End Function
>
>プロシジャーtestは一例ですから、このプロシジャーに一万行の
>ループ処理と言う事になりますが・・・。
>
>確認してみて下さい。

【25349】Re:文字の置き換え
回答  Hirofumi  - 05/5/29(日) 10:35 -

引用なし
パスワード
   考え過ぎで、こっちの方が速い見たい?

Public Function GetPurpose(ByVal strMark As String) As String

  Dim i As Long
  Dim strResult As String
  Dim strLetter As String
  Dim blnWide As Boolean
  Dim strReplace As String
  
  If strMark = "" Then
    Exit Function
  End If
  
  strMark = StrConv(strMark, vbNarrow)
  strReplace = "-"
  
  For i = 1 To Len(strMark)
    strLetter = Mid(strMark, i, 1)
    If LenB(StrConv(strLetter, vbFromUnicode)) <> 2 _
        And strLetter <> strReplace Then
      blnWide = False
      strResult = strResult & strLetter
    Else
      If Not blnWide Then
        blnWide = True
        strResult = strResult & strReplace
      End If
    End If
  Next i
      
  If blnWide Then
    strResult = Left(strResult, Len(strResult) - 1)
  End If
  
  GetPurpose = strResult
  
End Function

【25359】Re:文字の置き換え 一箇所訂正
お礼  hiroshi E-MAIL  - 05/5/29(日) 15:49 -

引用なし
パスワード
   ▼ichinose さん:
有り難うございます。
参考にさせていただきます。
今後ともよろしくお願い致します。

【25360】Re:文字の置き換え
お礼  hiroshi E-MAIL  - 05/5/29(日) 15:50 -

引用なし
パスワード
   有り難うございます。
参考にさせていただきます。
今後ともよろしくお願いします。

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