Excel VBA質問箱 IV

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

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


56150 / 76732 ←次へ | 前へ→

【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
0 hits

【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 お礼

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