質問番号：1471574675

VBA 人力検索

http://q.hatena.ne.jp/1471574675

Excelの特定のセルで計算を行いたいが同時に日本語も入れたい
今、C20セル〜から数行に渡り、

営業費8,000円×30＝
管理費5,000円×20＝
撮影費1,000円×15＝
・
・
・
と、計算を含む文字列が入っております。
上記の費用の計算結果を、D20セル以下に表記したいのですが。

余計な日本語や全角の記号（×や＝）が混じっているので、単純にセルに“=”を入れて掛算式を入れても、うまく計算ができないです。

しかし書類の仕様上、それらの日本語を消すことも出来ない状況です。

日本語の●●費等を残しつつも、C列に計算式を入れて、同時に計算結果をD列に反映するような妙案はないでしょうか。

よろしくお願い致します。

汎用性を持たせる為に、数字、小数点、演算子に全角・半角が混在していても計算する様にしました。

プログラム

Option Explicit

Function StrToFormula(ByVal Str As String) As Variant

    Dim FirstNo As Variant  ' 第一引数
    Dim SecondNo As Variant ' 第二引数
    Dim Operator As String  ' 演算子

    Dim Flag As Boolean
    Dim lp As Integer

    ' コンマを削除
    Str = Replace(Str, ",", "")

    ' 演算子抽出
    Flag = True
    If InStr(Str, "＋") > 0 Or InStr(Str, "+") > 0 Then
        Operator = "+"
        Str = Replace(Str, "＋", ",")
        Str = Replace(Str, "+", ",")
    
    ElseIf InStr(Str, "−") > 0 Or InStr(Str, "-") > 0 Then
        Operator = "-"
        Str = Replace(Str, "−", ",")
        Str = Replace(Str, "-", ",")
    
    ElseIf InStr(Str, "×") > 0 Or InStr(Str, "*") > 0 Then
        Operator = "*"
        Str = Replace(Str, "×", ",")
        Str = Replace(Str, "*", ",")
    
    ElseIf InStr(Str, "÷") > 0 Or InStr(Str, "/") > 0 Then
        Operator = "/"
        Str = Replace(Str, "÷", ",")
        Str = Replace(Str, "/", ",")
    
    Else
        Flag = False
    End If

    ' 演算子が無い
    If Flag = False Then
        StrToFormula = ""
        Exit Function
    End If

    '演算子で分割
    FirstNo = Split(Str, ",")(0)
    SecondNo = Split(Str, ",")(1)
    
    ' 数字と小数点以外の文字を空白に変換した後、削除
    For lp = 1 To Len(FirstNo)
        If (Mid(FirstNo, lp, 1) >= "0" And Mid(FirstNo, lp, 1) <= "9") = False And _
            (Mid(FirstNo, lp, 1) >= "０" And Mid(FirstNo, lp, 1) <= "９") = False And _
            (Mid(FirstNo, lp, 1) = "." And Mid(FirstNo, lp, 1) = "．") = False Then
            Mid(FirstNo, lp, 1) = " "
        End If
    Next lp
    
    FirstNo = StrConv(Replace(FirstNo, " ", ""), vbNarrow)
    
    For lp = 1 To Len(SecondNo)
        If (Mid(SecondNo, lp, 1) >= "0" And Mid(SecondNo, lp, 1) <= "9") = False And _
            (Mid(SecondNo, lp, 1) >= "０" And Mid(SecondNo, lp, 1) <= "９") = False And _
            (Mid(SecondNo, lp, 1) = "." And Mid(SecondNo, lp, 1) = "．") = False Then
            Mid(SecondNo, lp, 1) = " "
        End If
    Next lp
    
    SecondNo = StrConv(Replace(SecondNo, " ", ""), vbNarrow)

    ' 抽出した数字と演算子で計算
    Select Case Operator
        Case "+"
            StrToFormula = Val(FirstNo) + Val(SecondNo)
        
        Case "-"
            StrToFormula = Val(FirstNo) - Val(SecondNo)

        Case "*"
            StrToFormula = Val(FirstNo) * Val(SecondNo)
            
        Case "/"
            StrToFormula = Val(FirstNo) / Val(SecondNo)
    End Select

End Function
標準モジュールに記述

結果

質問番号：11162376606

Yahoo知恵袋 VBA


http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q11162376606

下記のフォルダーにPDF形式の図面ファイルを入れてあります。
C:\Users\kojin\Desktop\製造工程\図面\123.pdf 等

これら図面をExcelVba にて印刷したいのですが
但しPDFファイルを開かず実行できるのがBestですが
印刷終了後はpdfを閉じるようにしたいと思っております。

どなたかご教授頂ければ助かります。


プログラム

Option Explicit

' レジストリ値取得用API
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
        (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
        ByVal samDesired As Long, phkResult As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
        (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
        lpType As Long, lpData As Any, lpcbData As Long) As Long

' レジストリ値取得用定数
Const KEY_QUERY_VALUE = &H1
Const HKEY_LOCAL_MACHINE = &H80000002

' PDF印刷用定数
Const PrintOK As Integer = 0
Const NoFile As Integer = -1
Const StatusNG As Integer = -2
Const AdobeReaderNG As Integer = -3


'概要 Yahoo知恵袋 質問番号:Q11162376606 2016.08.02

Sub Main()

Dim DirName As String
Dim FileName As String
Dim Res As Integer

'    DirName = "C:\Users\kojin\Desktop\製造工程\図面\"
'    FileName = "123.pdf"
    
    DirName = "Z:\"
    FileName = "sample.pdf"
    
    Res = PDFPrint(DirName, FileName)
    If Res = NoFile Then
        MsgBox "指定されたファイルは存在しません！", vbExclamation + vbOKOnly
    ElseIf Res = StatusNG Then
        MsgBox "通常使うプリンタのステータスが取得できません！", vbExclamation + vbOKOnly
    ElseIf Res = AdobeReaderNG Then
        MsgBox "Acrobat Readerがインストールされていません！", vbExclamation + vbOKOnly
    End If

End Sub


'概要 コマンドラインから指定されたPDFファイルを印刷する
'
'引数 DirName  : 印刷するPDFファイルのフォルダ名
'     FileName : 印刷するPDFファイル名
'
'返値 PrintOK (0)       : 正常終了
'     NoFile(-1)        : 指定されたPDFファイルが存在しない
'     StatusNG(-2)      : プリンタ名、ドライバ名、ポート名のいずれかの情報が取得できない
'     AdobeReaderNG(-3) : Adobe Readerがインストールされていない

Private Function PDFPrint(DirName As String, FileName As String) As Integer

Dim WSH As Object
Dim WExec As Object
Dim Path As String
Dim Result As String

Dim PrinterName As String
Dim DriverName As String
Dim PortName As String

Dim AdobeReaderInstallFolder As String
Dim CommandCode As String

Dim Tmp As Variant
Dim lp As Integer
   
    ' 指定されたPDFファイルが存在するか？
    If Right(DirName, 1) <> "\" Then
        DirName = DirName & "\"
    End If
    
    If Dir(DirName & FileName) = "" Then
        PDFPrint = NoFile
        Exit Function
    End If
    
    ' OSのバージョンチェック
    If InStr(Application.OperatingSystem, "5.01") > 0 Then
        Path = "C:\Windows\System32\"   ' WindowsXP
    Else
        Path = "C:\Windows\System32\Printing_Admin_Scripts\ja-JP\"      ' Windows Vista以上
    End If
    
    Set WSH = CreateObject("WScript.Shell")
    
    ' 通常使うプリンタ名取得
    Set WExec = WSH.exec("cscript " & Path & "prnmngr.vbs -g")
    
    Result = WExec.StdOut.ReadAll
    
    Tmp = Split(Result, vbCrLf)
    PrinterName = Split(Tmp(3), ": ")(1)

    ' ドライバ名・ポート名取得
    Set WExec = WSH.exec("cscript " & Path & "prnmngr.vbs -l")

    Result = WExec.StdOut.ReadAll

    Tmp = Split(Result, vbCrLf)

    lp = 0
    Do While UBound(Tmp) >= lp
        If InStr(Tmp(lp), "プリンター名 ") > 0 Then
            If InStr(Tmp(lp), PrinterName) > 0 Then
                DriverName = Replace(Tmp(lp + 2), "ドライバー名 ", "")
                PortName = Replace(Tmp(lp + 3), "ポート名 ", "")
                Exit Do
            End If
        End If
        lp = lp + 1
    Loop


    ' プリンタのステータスが取得できない
    If PrinterName = "" Or DriverName = "" Or PortName = "" Then
        Set WSH = Nothing
        Set WExec = Nothing
        PDFPrint = StatusNG
        Exit Function
    End If

    ' Acrobat Reader(Adobe Reader)のインストールパスをレジストリから取得
    AdobeReaderInstallFolder = GetRegValue(HKEY_LOCAL_MACHINE, _
        "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\AcroRd32.exe", "Path")
    
    If AdobeReaderInstallFolder = "" Then
        Set WSH = Nothing
        Set WExec = Nothing
        PDFPrint = AdobeReaderNG
        Exit Function
    End If

    ' PDFファイルを印刷
    CommandCode = AdobeReaderInstallFolder & "AcroRd32.exe /t " & DirName & FileName & " " & _
        Chr(34) & PrinterName & Chr(34) & " " & Chr(34) & DriverName & Chr(34) & " " & PortName
    Set WExec = WSH.exec(CommandCode)
    
    ' AdobeReaderを閉じる
    CommandCode = "taskkill /IM AcroRd32.exe"
    Set WExec = WSH.exec(CommandCode)
    
    Set WSH = Nothing
    Set WExec = Nothing
    PDFPrint = PrintOK

End Function


'概要 レジストリの値を取得する
'
'引数 lngRootKey : レジストリルートキー
'     strSubKey  : レジストリサブキー
'     strName    : 名前
'
'返値 取得したレジストリの値
'
'注釈 「EXCEL VBA：レジストリ情報取得・yuriのIT手帳」(http://blog.livedoor.jp/yorinaga/archives/52016032.html)参照

Function GetRegValue(lngRootKey As Long, strSubKey As String, strName As String) As String

    Dim lngRet As Long
    Dim hWnd As Long
    Dim strValue As String


    'ハンドルを開く
    hWnd = Application.hWnd

    lngRet = RegOpenKeyEx(lngRootKey, strSubKey, 0, KEY_QUERY_VALUE, hWnd)

    '受け取り値用のバッファを確保
    strValue = String(255, " ")

    '値を取得
    lngRet = RegQueryValueEx(hWnd, strName, 0, 0, ByVal strValue, LenB(strValue))

    'ハンドルを閉じる
    RegCloseKey hWnd

    '取得した値から後続のNullを取り除く
    strValue = Left(strValue, InStr(strValue, vbNullChar) - 1)

    '取得した値を返り値に設定
    GetRegValue = strValue

End Function

参考サイト

Windowsのバージョン情報取得

https://www.moug.net/tech/exvba/0150124.html
Windowsの種類を取得する・morg(モーグ）

プリンタの情報（既定のプリンタ名、ドライバ名、ポート名）

http://www.town.yakumo.lg.jp/modules/information_blog/details.php?bid=871
プリンタの情報取得・北海道八雲町情報政策課ブログ

https://msdn.microsoft.com/ja-jp/library/cc772768(v=ws.10).aspx
Prnmngr.vbs・マイクロソフト

Prnmngr.vbs

プリンタまたはプリンタ接続を追加、削除、および一覧表示します。また、既定のプリンタを設定および表示します。パラメータを付けずに prnmngr.vbs を実行すると、prnmngr.vbs コマンドのコマンド ライン ヘルプが表示されます。

Adobe Readerのプロパティ取得及び印刷（Adobe Readerのインストールフォルダ）

https://helpx.adobe.com/jp/acrobat/kb/511265.html
レジストリから Acrobat・Adobe Reader のバージョン情報を得る方法について（別解）・Adobe

http://pdf-file.nnn2.com/?p=222
WINDOWS のコマンドラインから ACROBAT や ADOBE READER を使用して印刷する方法・VBA(Excel)からAcrobat経由でPDFをプログラミング操作(OLE:IAC)する

http://blog.livedoor.jp/yorinaga/archives/52016032.html
EXCEL VBA：レジストリ情報取得・yuriのIT手帳

質問番号：1467245868

人力検索 VBA

指定した約1000のキーワードを含む行を削除したいです
今、Sheet1のA列にずらりとデータが2万行ほど並んでいます。
そしてSheet2のC列に、1000行ほどデータが並んでおります。

この状況におきまして、Sheet2のC列の1000行（1000セル）のデータの各文字列が、もしSheet1のA列の各セル（20000セル）に含まれていた場合。
該当するA列のデータを、行ごと削除していきたいのです。

そのような処理がマクロ等で可能でしたらお教えいただけないでしょうか。
よろしくお願い致します。

質問文の内容とは少し違いますが、セルの値を検索する方法を４つのアルゴリズムで比較してみました。

比較アルゴリズム

・検査値のセルと検索値のセルを単純に２重ループで比較(Test1)

・Match関数（ワークシート関数）を利用して検索(Test2)

・検査値と検索値をバリアント配列にコピーした後、２重ループで比較(Test3)

・Findメゾットを利用して検索(Test4)

条件

・全部の方法で同一のデータを利用する。（検査値、検索値共に数字・アルファベット大文字小文字をランダムに10文字抽出）
　　（テストデータは「ランダム文字列ジェネレータ」http://app.nanoway.net/random/ を利用しました。）

・検索値は必ず見つかるものとする。（見つからない場合の処理は今回省略）

・検査値が見つかったら、対応する配列にTrue（論理値）をセットする。

プログラム

Option Explicit

Const Quantity As Integer = 100 ' 検索件数

Sub main()

    Dim StartTime As Date
    Dim EndTime As Date
    Dim DustTime1 As Date
    Dim DustTime2 As Date
    Dim DustTime3 As Date
    Dim DustTime4 As Date
    
    StartTime = Time
    Call Test1
    EndTime = Time
    DustTime1 = EndTime - StartTime
    
    StartTime = Time
    Call Test2
    EndTime = Time
    DustTime2 = EndTime - StartTime
    
    StartTime = Time
    Call Test3
    EndTime = Time
    DustTime3 = EndTime - StartTime
    
    StartTime = Time
    Call Test4
    EndTime = Time
    DustTime4 = EndTime - StartTime
    
    MsgBox "検索件数:" & Quantity & vbCrLf & "TEST1:" & Format(DustTime1, "hh:mm:ss") & vbCrLf & "TEST2:" & Format(DustTime2, "hh:mm:ss") & vbCrLf & "TEST3:" & _
        Format(DustTime3, "hh:mm:ss") & vbCrLf & "TEST4:" & Format(DustTime4, "hh:mm:ss")
    
End Sub


Function Test1()

    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim MaxRow As Integer
    Dim MatchFlag(20000) As Boolean
    Dim lp1 As Integer
    Dim lp2 As Integer

    Set WS1 = Worksheets(1)
    Set WS2 = Worksheets(2)
    MaxRow = WS1.Range("A" & Rows.Count).End(xlUp).Row
    
    For lp1 = 1 To Quantity
        For lp2 = 1 To MaxRow
            If WS2.Cells(lp1, 1) = WS1.Cells(lp2, 1) Then
                MatchFlag(lp2) = True
                Exit For
            End If
        Next lp2
    Next lp1

End Function


Function Test2()

    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim RowNo As Integer
    Dim MatchFlag(20000) As Boolean
    Dim lp1 As Integer

    Set WS1 = Worksheets(1)
    Set WS2 = Worksheets(2)
    
    For lp1 = 1 To Quantity
        RowNo = Application.WorksheetFunction.Match(WS2.Cells(lp1, 1).Value, WS1.Range("A:A"), 0)
        MatchFlag(RowNo) = True
    Next lp1

End Function


Function Test3()

    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim MaxRow As Integer
    Dim Comp1 As Variant
    Dim Comp2 As Variant
    Dim MatchFlag(20000) As Boolean
    Dim lp1 As Integer
    Dim lp2 As Integer

    Set WS1 = Worksheets(1)
    Set WS2 = Worksheets(2)
    
    Comp1 = WS1.Range("A1:A20000")
    Comp2 = WS2.Range("A1:A" & Quantity)
   
    MaxRow = WS1.Range("A" & Rows.Count).End(xlUp).Row
    For lp1 = 1 To Quantity
        For lp2 = 1 To MaxRow
            If Comp2(lp1, 1) = Comp1(lp2, 1) Then
                MatchFlag(lp1) = True
                Exit For
            End If
        Next lp2
    Next lp1

End Function


Function Test4()

    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim RowNo As Integer
    Dim MatchFlag(20000) As Boolean
    Dim lp1 As Integer

    Set WS1 = Worksheets(1)
    Set WS2 = Worksheets(2)

    For lp1 = 1 To Quantity
        RowNo = WS1.Cells.Find(WS2.Cells(lp1, 1)).Row
        MatchFlag(RowNo) = True
    Next lp1

End Function

結果

4種類のアルゴリズムで一番早かったのはMatch関数(Test2)を用いた方法でした。　ただ、バリアント配列(Test3)やFindメゾット（Test4)を用いた方法も実用に耐えうる速度が出ていると思います。

質問番号：11157355186

Yahoo知恵袋 VBA

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q11157355186

エクセルVBAについての質問です。キーボードの矢印によってセルの値を変える方法を教えてください。
例として、矢印↑を押すとセルA11の値に+１されて、矢印↓を押すとセルA１１−１される。
また、矢印→を押すとセルK1の値に＋１され、矢印←を押すとセルK１の値にー１される方法を教えてください。

回答

標準モジュール
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
シート1
Option Explicit

Sub main()

    Do While (1)
    
        DoEvents
    
        ' ↑キーが押されたらA11セルの値をカウントアップ
        If GetAsyncKeyState(vbKeyUp) <> 0 Then
            Range("A11").Value = Range("A11").Value + 1
            Range("A11").Select
            Sleep (100)
        End If
        
        ' ↓キーが押されたらA11セルの値をカウントダウン
        If GetAsyncKeyState(vbKeyDown) <> 0 Then
            Range("A11").Value = Range("A11").Value - 1
            Range("A11").Select
            Sleep (100)
        End If
    
        ' →キーが押されたらK1セルの値をカウントアップ
        If GetAsyncKeyState(vbKeyRight) <> 0 Then
            Range("K1").Value = Range("K1").Value + 1
            Range("K1").Select
            Sleep (100)
        End If
        
        ' ←キーが押されたらK1セルの値をカウントダウン
        If GetAsyncKeyState(vbKeyLeft) <> 0 Then
            Range("K1").Value = Range("K1").Value - 1
            Range("K1").Select
            Sleep (100)
        End If
    
        ' エスケープキーが押されたら処理終了
        If GetAsyncKeyState(vbKeyEscape) <> 0 Then
            Exit Do
        End If
    Loop

End Sub

質問番号：1446515298

人力検索 VBA

2〜4つの文字数バラバラの単語で構成される文字列を並べ替える方法につきまして

今、A列に次のような文字列が10000行近く、ずらりと並んでおります。

単語A★単語B★単語C■
単語D★単語E★単語F★単語G■
単語H★単語I■
単語J★単語K★単語L■
単語M★単語N■
単語O★単語P★単語Q★単語R■
・
・
・

1つのセルは2〜4つの単語の文字列が入っております。
それぞれの単語自体はバラバラで特に規則性はないです。
単語と単語の間に★印があり、最後の単語の後ろには■がくっ付いております。
上記の状態から、

単語C■単語A★単語B★
単語G■単語D★単語E★単語F★
単語I■単語H★
単語L■単語J★単語K★
単語N■単語M★
単語R■単語O★単語P★単語Q★
・
・
・

と、並べ替えを行いたいのです。
量が多くて困っているのですが・・・何かよい並べ替えのマクロや関数等ありましたら、
お教えいただけないでしょうか。

よろしくお願い致します。

2015.11.05追記 回答プログラムは実行したいシートに貼り付けてください。

回答

Option Explicit

Sub StringExchange()

    Dim MAXROW As Long
    Dim SPCount As Integer
    Dim lp As Long
    Const SPChar As String = "★"

    MAXROW = Me.Range("A" & Rows.Count).End(xlUp).Row
        
    ' 0行の場合は即終了
    If MAXROW < 1 Then
       Exit Sub
    End If
              
    For lp = 1 To MAXROW

        If Len(Cells(lp, 1)) > 0 Then
        
           ' 文字列後ろから★を探す
            SPCount = InStrRev(Cells(lp, 1), SPChar)
            If SPCount > 0 Then
                Cells(lp, 2) = Mid(Cells(lp, 1), SPCount + 1, Len(Cells(lp, 1))) & Left(Cells(lp, 1), SPCount)
            Else
                Cells(lp, 2) = Cells(lp, 1)
            End If
        End If
    Next lp

End Sub

出力結果

質問番号：1440684528

人力検索 VBA

Excelの質問です。一番右端の半角スペース以降の文字列をすべて削除するような関数やマクロはないでしょうか。
今、B列に次のようなデータが、4万行近く並んでおります。

                                            • -

らくだ 動物 アフリカ
らくだ 動物 特徴
らくだ 生息地 アジア
らくだ 生態 進化の過程
・・・

                                            • -


といった感じです。
この状態から、一番右端の半角スペース以降の文字列全てを削除したいので、

                                            • -

らくだ 動物
らくだ 動物
らくだ 生息地
らくだ 生態
・・・

                                            • -

のようにしたいのですが・・・データが膨大で、手作業で行うのは途方もない作業です。
関数やマクロを用いて、何とか効率的に文字列を削除する方法はないでしょうか。

よろしくお願い致します。

回答

Option Explicit

Sub main()

    Dim MAXROW As Long
    Dim SPCount As Integer
    Dim lp As Long
    Const SPChar As String = " "

    MAXROW = Me.Range("A" & Rows.Count).End(xlUp).Row
        
    If MAXROW < 1 Then
       Exit Sub
    End If
              
    For lp = 1 To MAXROW

        ' 文字列後ろからスペースを探す
        SPCount = InStrRev(Cells(lp, 1), SPChar)
        If SPCount > 0 Then
            Cells(lp, 2) = Left(Cells(lp, 1), SPCount - 1)
        Else
            Cells(lp, 2) = Cells(lp, 1)
        End If
    Next lp

End Sub

出力結果

http://officetanaka.net/excel/vba/function/InStrRev.htm
InStrRev関数(Office Tanaka)

質問番号：14148951214

Yahoo知恵袋 VBA

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14148951214

セル内の文字列の改行をVBAでプログラミングしたいと思っています。
エクセルVBAの初心者です。よろしくお願いします。

特定のセル内に以下の文字列が入っていたとします。

  1. aaaaaaaaa+bbbbb+cccccccc+ddddddd+eeeeeee

この文字列を、

  1. aaaaaaaaa
  2. bbbbb
  3. cccccccc
  4. ddddddd
  5. eeeeeee

といった感じで、「+」の前で改行するには、どのようにVBAでプログラミングすればいいか、ご教授お願いします。
なお、「+」の数や、「+」と次の「+」間の文字数（上記の例だと、「a」「b」「c」とかの文字数）は全く決まっていません。

初心者でうまく質問できているか不安ですが、どうかよろしくお願いします。

回答

Option Explicit
Option Base 1
Sub main()

    Dim BeforeString As String      ' 分割前文字列
    Dim AfterString As Variant      ' 分割後文字列配列
    Dim Delimiter As String         ' 区切り文字
    Dim lp As Integer               ' ループカウンタ

    ' 区切り文字設定
    Delimiter = "+"

    ' A1セルの内容を分割前文字列にコピー
    BeforeString = Range("A1").Value

    ' 分割前文字列を区切り文字で分割
    AfterString = Split(BeforeString, Delimiter)

    ' 文字分割ができない場合は処理終了
    If UBound(AfterString) = 0 Then
        Exit Sub
    End If

    ' 分割後文字列配列の内容をB1セルから下にコピー
    For lp = 1 To UBound(AfterString)
        Range("B1").Offset(lp - 1).Value = AfterString(lp)
    Next lp

End Sub

参考サイト

http://officetanaka.net/excel/vba/tips/tips62.htm
Split関数で文字列を区切る・OFFICE TANAKA

http://www.moug.net/tech/exvba/0100023.html
文字列を分割し1次元配列として返す(Split関数)・moug