| |
こんなかな？
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim strResult() As String
Dim strProm As String
'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
'データが無い場合
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Resize(lngRows + 1).Value
End With
'画面更新を停止
Application.ScreenUpdating = False
ReDim strResult(1 To lngRows, 1 To 1)
For i = 1 To lngRows
strResult(i, 1) = NumberConv(vntData(i, 1))
Next i
rngList.Offset(, 1).Resize(lngRows).Value = strResult
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function NumberConv(ByVal vntValue As Variant) As String
Const cstrNumb As String = "0123456789"
Dim i As Long
Dim strResult As String
Dim strChr As String
If vntValue = "" Then
Exit Function
Else
vntValue = StrConv(vntValue, vbNarrow)
End If
For i = 1 To Len(vntValue)
strChr = Mid(vntValue, i, 1)
If InStr(1, cstrNumb, strChr, vbBinaryCompare) > 0 Then
strResult = strResult & strChr
End If
Next i
NumberConv = strResult
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
