Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

56156 / 76738

←次へ　｜　前へ→


	【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