Hatena::ブログ(Diary)

人は人、私は私、犬は犬 このページをアンテナに追加 RSSフィード Twitter

累計: 検索エンジン登録 本日: SEO対策 昨日: メール配信   アクセスアップ

2016-08-21(Sun) 質問番号:1471574675

[][]質問番号:1471574675


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

Excelの特定のセルで計算を行いたいが同時に日本語も入れたい

今、C20セル〜から数行に渡り、

営業費8,000円×30=
管理費5,000円×20=
撮影費1,000円×15=



と、計算を含む文字列が入っております。
上記の費用の計算結果を、D20セル以下に表記したいのですが。

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

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

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

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


f:id:Yoshiya:20160821115947p:image

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

プログラム

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) >= "0" And Mid(FirstNo, lp, 1) <= "9") = 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) >= "0" And Mid(SecondNo, lp, 1) <= "9") = 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


標準モジュールに記述

結果


f:id:Yoshiya:20160821123649p:image

2016-08-02(Tue) 質問番号:11162376606

[][]質問番号:11162376606



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

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

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

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


f:id:Yoshiya:20160802190114p:image

プログラム

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
レジストリから AcrobatAdobe Reader のバージョン情報を得る方法について(別解)・Adobe

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

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

2016-07-03(Sun) 質問番号:1467245868

[][]質問番号:1467245868


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

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

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


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

比較アルゴリズム

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

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

・検査値と検索値をバリアント配列にコピーした後、2重ループで比較(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

結果

f:id:Yoshiya:20160703024509p:image f:id:Yoshiya:20160703024508p:image f:id:Yoshiya:20160703024507p:image f:id:Yoshiya:20160703024506p:image f:id:Yoshiya:20160703024505p:image f:id:Yoshiya:20160703024504p:image f:id:Yoshiya:20160703024503p:image


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

2016-03-24(Thu) 質問番号:11157355186

[][]質問番号:11157355186


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

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

f:id:Yoshiya:20160324061247p:image


回答


標準モジュール
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

2015-11-04(Wed) 質問番号:1446515298

[][]質問番号:1446515298


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

出力結果

f:id:Yoshiya:20151103231828j:image

2015-08-27(Thu) 質問番号:1440684528

[][]質問番号:1440684528


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

出力結果

f:id:Yoshiya:20150828023753j:image


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

2015-08-12(Wed) 質問番号:14148951214

[][]質問番号:14148951214


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

f:id:Yoshiya:20150812095157j:image


参考サイト

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

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

2015-07-23(Thu) 質問番号:1437189907

[][]質問番号:1437189907


Excelマクロを使って2つの住所の直線距離を求めたいです。

今、Sheet1のA1セルに、大阪にある通天閣の住所が記載されております。
A2セルに四天王寺A3セルに大阪城と、周辺のスポットの住所が記載されています。
そういうスポット情報が、A2セルから2万行ぐらいあります。

この状況から、A1セルの通天閣の住所と、各セルの住所の直線距離を調べ、その距離をB列などに出力するような。
そんな処理がもし可能でしたら、お教えいただきたいのですが。
2点間の距離を調べられるサイトは多く見つけられたのですが、一度に処理できる方法を見つけることが出来ませんでして。

よろしくお願い致します。
http://q.hatena.ne.jp/images/question/1437189/1437189907.jpg


Google Maps API V3を使ったプログラムは質問内(http://q.hatena.ne.jp/1437189907)で回答がなされているので、私は別のAPIを利用したプログラムを作成してみました。
住所→緯度経度変換には「Yahoo!ジオコーダAPI(要アプリケーションID)」(Yahoo Maps)、2点間の距離は「距離と方位角の計算API」(測量計算サイト・国土地理院)を利用しました。

http://developer.yahoo.co.jp/webapi/map/openlocalplatform/v1/geocoder.html
デベロッパーネットワークトップ > YOLP(地図) > Yahoo!ジオコーダAPIYahoo! JAPAN)

http://vldb.gsi.go.jp/sokuchi/surveycalc/api_help.html
測量計算サイト > API使用法 > 距離と方位角の計算(入力パラメータ


なお、2点間の距離にはヒュベニの公式も利用しています。
サンプルデータについては、冠婚葬祭ネット(寺社一覧)から2万件を抽出しました。

参考サイト

http://www.yahoo-help.jp/app/answers/detail/p/537/a_id/43398
アプリケーションIDを登録する(Yahoo!デベロッパーネットワークヘルプ)

http://veaba.keemoosoft.com/2013/01/474/
住所から緯度経度を取得する(ヴィーバ VeaBa! Excel VBA Tips

http://tancro.e-central.tv/grandmaster/excel/hubenystandard.html
VBAと測地>Hubenyの式を考察(師匠の散歩)

http://www.touse-web.com/tera/
寺院一覧(冠婚葬祭ネット)

http://www.kyori.jp/setaddr.asp?step=1&fromIdo=no&fromKeido=no&from=no
2点間の直線距離がわかる距離計算サイト(株式会社プロネット)


回答

' 回答プログラム(質問番号:1437189907)
' Author Y.Yoshiya
' Date 2015/07/20

Option Explicit
Option Base 0

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)     'Sleep用
Const YahooAPIKey = ""

Sub main()
 
    Dim Ido1, Keido1 As Single
    Dim Ido2, Keido2 As Single
    Dim IdoKeido As Variant

    Dim MAXROW As Long
    Dim lp As Long
    Dim StartTime, EndTime As Date

    Application.ScreenUpdating = False

    StartTime = Time

    With Worksheets(1)
        MAXROW = .Range("A" & Rows.Count).End(xlUp).Row
        
        If MAXROW < 1 Then
           Exit Sub
        End If
                      
        IdoKeido = GetLocation(.Range("$A$1"))
        Keido1 = IdoKeido(0)
        Ido1 = IdoKeido(1)
        .Range("E1") = Format(Ido1, "0.00000")
        .Range("F1") = Format(Keido1, "0.00000")
        
        For lp = 1 To MAXROW - 1
            IdoKeido = GetLocation(Range("A1").Offset(lp))
            Keido2 = IdoKeido(0)
            Ido2 = IdoKeido(1)
            .Range("E1").Offset(lp) = Format(Ido2, "0.00000")
            .Range("F1").Offset(lp) = Format(Keido2, "0.00000")

            .Range("B1").Offset(lp) = Format(Distance(Ido1, Keido1, Ido2, Keido2) / 1000, "0.000")
            .Range("C1").Offset(lp) = Format(Distance2(Ido1, Keido1, Ido2, Keido2) / 1000, "0.000")

            Call StatusBar(lp, MAXROW - 1)
            Call Sleep(1000)
        Next lp
    End With

    EndTime = Time
    Debug.Print "StartTime = ", StartTime & vbCrLf & "EndTime = ", EndTime & vbCrLf & "Time =", DateDiff("s", StartTime, EndTime)
    
    Application.ScreenUpdating = True
   
End Sub


Private Function Distance(ByVal Ido1 As Single, ByVal Keido1 As Single, ByVal Ido2 As Single, ByVal Keido2 As Single) As Single

    Dim Ido1Rad, Keido1Rad As Single        ' 開始点緯度・経度(ラジアン)
    Dim Ido2Rad, Keido2Rad As Single        ' 終了点緯度・経度(ラジアン)
    Dim P As Single                         ' 2点の平均緯度
    Dim dP As Single                        ' 2点の緯度差
    Dim dR As Single                        ' 2点の経度差
    Dim M As Single                         ' 子午線曲率半径
    Dim N As Single                         ' 卯酉線曲率半径
    Dim Pi As Single                        ' 円周率

    ' ヒュベニの公式
    Pi = Application.WorksheetFunction.Pi()
    Ido1Rad = Ido1 * Pi / 180
    Ido2Rad = Ido2 * Pi / 180
    Keido1Rad = Keido1 * Pi / 180
    Keido2Rad = Keido2 * Pi / 180
    P = (Ido1Rad + Ido2Rad) / 2
    dP = Ido1Rad - Ido2Rad
    dR = Keido1Rad - Keido2Rad
    M = 6334834 / Sqr((1 - 0.006674 * Sin(P) ^ 2) ^ 3)
    N = 6377397 / Sqr(1 - 0.006674 * Sin(P) ^ 2)

    Distance = Sqr((M * dP) ^ 2 + (N * Cos(P) * dR) ^ 2)

End Function


Private Function Distance2(ByVal Ido1 As Single, ByVal Keido1 As Single, ByVal Ido2 As Single, ByVal Keido2 As Single) As Single
    
    Dim URL As String
    Dim xml As Object
    
    Set xml = CreateObject("MSXML2.XMLHTTP")

    ' 国土地理院 測量計算サイト・距離と方位角の計算APIを利用 (http://vldb.gsi.go.jp/sokuchi/surveycalc/api_help.html)
    URL = "http://vldb.gsi.go.jp/sokuchi/surveycalc/surveycalc/bl2st_calc.pl?latitude1=" & Ido1 & "&longitude1=" & Keido1 & "&latitude2=" & Ido2 & "&longitude2=" & Keido2 & "&outputType=xml&ellipsoid=GRS80"

    With xml
        .Open "GET", URL, False
        .send
        With .responseXML
            Distance2 = .getElementsByTagName("geoLength").Item(0).Text
        End With
    End With

    Set xml = Nothing

End Function


Private Function GetLocation(ByVal Address As String) As Variant

    Dim URL As String
    Dim xml As Object
    
    Set xml = CreateObject("MSXML2.XMLHTTP")

    If Not IsEmpty(Address) Then
        Address = AscEx(Address)
        URL = "http://geo.search.olp.yahooapis.jp/OpenLocalPlatform/V1/geoCoder?appid=" & YahooAPIKey & "&query=" & EncodeURI(Address) & "&al=3&ar=le&recursive=true"
        
        With xml
            .Open "GET", URL, False
            .send
            With .responseXML
                If .getElementsByTagName("Count").Item(0).Text > 0 Then
                    GetLocation = Split(.getElementsByTagName("Coordinates").Item(0).Text, ",")
                End If
            End With
        End With
    End If
    
    Set xml = Nothing
 
End Function


Private Function EncodeURI(ByVal argString As String) As String

    argString = Replace(Replace(argString, "\", "\\"), "'", "\'")
    
    With CreateObject("HtmlFile")
        .parentWindow.execScript "document.write(encodeURIComponent('" & argString & "'));", "JScript"
        EncodeURI = .Body.innerHTML
    End With

End Function


Private Function StatusBar(Bunshi As Long, Bunbo As Long)

    Dim lp As Long
    Dim Parcent As Single
    Dim BarCount As Integer

    Application.StatusBar = True
    Parcent = (Bunshi / Bunbo) * 100
    BarCount = Int(Parcent / 5)
    DoEvents
    Application.StatusBar = "処理中..." & Format(Parcent, "0.00") & "%" & String(BarCount, "■")

End Function


Private Function AscEx(strOrg As String) As String

    Dim strRet As String
    Dim lp As Integer
    Dim strChar As String
    
    strRet = ""
    
    For lp = 1 To Len(strOrg)
        strChar = Mid(strOrg, lp, 1)
        
        If (strChar >= "0" And strChar <= "9") Or (strChar >= "A" And strChar <= "Z") Or (strChar >= "a" And strChar <= "z") Then
            strRet = strRet & StrConv(strChar, vbNarrow)
        Else
            strRet = strRet & strChar
        End If
    Next lp
   
    AscEx = strRet

End Function

出力結果

f:id:Yoshiya:20150723231826j:image

B列はヒュベニの公式で計算した距離、C列は距離と方位角の計算API(測量計算サイト)を利用した距離



追記


地図の表示を伴わないGoogle Geocoding API単独での利用は利用規約で禁止されているそうです。
また、Google MAPS APIの利用制限については、最大2500回/1日です。

参考サイト

http://syncer.jp/how-to-use-geocoding-api
ジオコーディングと逆ジオコーディングをする方法(Google Geocoding APIの使い方)

1日のリクエスト回数
Google Geocoding APIは、API KEYを用いずに、気軽に利用できるAPIですが、1日あたりのリクエスト数に厳しめの上限回数が設定されています。一般ユーザーは2,500回、ビジネスユーザーは100,000回となっています。


Google Mapsとの組み合わせが必要
このGeocoding APIで取得したデータは、Google Mapsに反映させる目的でのみ、使用が許可されています。必ず、同ページにGoogle Mapsの地図を表示するようにしましょう。下記は注意書きの引用です。

Geocoding APIGoogle マップ上の結果表示と組み合わせる場合にのみ使用できます。地図に表示せずにジオコーディングの結果だけを利用することは禁止されています。許可されている使用方法の詳細については、Maps API 利用規約ライセンス制限をご覧ください。

原文(サービス > Google Maps APIs > Google Maps API Web Services > Google Maps Geocoding API

The Geocoding API may only be used in conjunction with a Google map; geocoding results without displaying them on a map is prohibited. For complete details on allowed usage, consult the Maps API Terms of Service License Restrictions.


Yahoo!が提供しているWeb APIの利用制限についてですが、1アプリケーションIDにつき最大50000回/1日だそうです。
1ユーザーで最大10個のアプリケーションIDが取得できるそうなので、最大利用すると1日に500000回までWEB APIが利用できそうです。

デベロッパーネットワークトップ > 開発のヒント > 利用制限についてYahoo! JAPAN

f:id:Yoshiya:20150724030805j:image

f:id:Yoshiya:20150724031151j:image

https://app.box.com/s/zetrz21f02dl0bsb8bicdvxihe1kxbah

2015-06-25(Thu) 質問番号:1435032470

[][]質問番号:1435032470


長い複数のURLを一度に短縮する方法はないでしょうか。

今、ExcelファイルのA1セルからA2300セルほどに、長いURLが記載されています。
長くて複数のURLを一度に短縮し、B1〜B2300セルに貼り付けたりする方法はないかと、
ここ数日、Googleで検索してかなり探してみたのですが…。
情報が古く、今現在は対応していなかったり。
ソフトウェア等もダウンロードしてみましたが、古いソフトなのか、短縮に失敗したりと。
お手上げ状態になっておりまして。
もし、今現在でも有効な、複数のURLを短縮する方法をご存じの方がいらっしゃいましたら。
お教えいただければ幸いです。
よろしくお願い致します。


Google URL Shortener API(Google短縮URLサービス)を利用して、プログラムを作成してみました。
なお、サンプルシートではC列に短縮したいURL、D列に短縮されたURLが出力されているので、質問内容と一部異なります。
プログラムはThis WorkBookに記述しています。


サンプルデータは「気象庁 気象警報・注意報 市町村ページURL一覧」(1741件)を利用しました。

処理前手順

Google URL Shortener APIを利用するには、あらかじめAPIキーを取得する必要があります。

APIキーの取得・Google Maps API入門

  (上記のサイトではGoogle MAPを利用する為のAPIキー取得方法を解説していますが、Google URL ShortenerAPIキーの取得方法は同じです。

f:id:Yoshiya:20150625090105j:image
Google URL Shortenerのリクエスト回数は100万回/1日の制限があります。)

f:id:Yoshiya:20150625090104j:image


回答

' 回答プログラム(質問番号:1435032470)
' Author Y.Yoshiya
' Date 2015/06/24

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)     ’Sleep用

Const API_KEY As String = ""         ' Your Google API key here(APIキーは事前に取得すること)
Const BASEURL As String = "https://www.googleapis.com/urlshortener/v1/url"  ' Google Shortener URL API

Sub main()
 
    Dim BeforeURL As String
    Dim AfterURL As String
    Dim MAXROW As Integer
    Dim lp As Integer
    Dim StartTime, EndTime As Date

    Dim ErrFlag As Boolean

    Application.ScreenUpdating = False

    StartTime = Time

    With Worksheets(1)
    
        MAXROW = .Range("C" & Rows.Count).End(xlUp).Row

        ErrFlag = False
        Do While (1)
            lp = 2
            Do While lp <= MAXROW
                BeforeURL = .Range("C" & lp).Value
                If .Range("D" & lp).Value = "" Then
                    AfterURL = GetGoogleURL(BeforeURL, API_KEY)
                    .Range("D" & lp).Value = AfterURL
                End If

                If AfterURL = "" Then
                    ErrFlag = True
                End If
                lp = lp + 1
            Loop

            If ErrFlag = False Then
                Exit Do
            End If
        Loop
          
    End With

    EndTime = Time
    Debug.Print "StartTime = ", StartTime & vbCrLf & "EndTime = ", EndTime & vbCrLf & "Time =", DateDiff("s", StartTime, EndTime)

    Application.ScreenUpdating = True
   
End Sub


Function GetGoogleURL(url As String, apiKey As String) As String
  
    Dim xml As Object  ' MSXML2.XMLHTTP60
    Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
 
    If xml Is Nothing Then Exit Function
 
    With xml
        .Open "POST", BASEURL & "?key=" & API_KEY, False
        .setRequestHeader "Content-Type", "application/json"
        .Send Replace("{""longUrl"": ""http://www.google.com/""}", "http://www.google.com/", url)
    End With
 
    If InStr(xml.responseText, "error") = 0 Then  ' no error occurred
        ' parse out short URL from JSON response
        GetGoogleURL = Trim$(Split(xml.responseText, """")(7))
    Else
        ' 5秒間隔を置く
        Call Sleep(5000)
        GetGoogleURL = GetGoogleURL(url, API_KEY)
    End If

End Function

Google URL Shortener APIから短縮URLを取得するサブルーチンは「Google URL Shortener API・JP SOFTWARE TECHNOLOGIES」を参照しました。
Google URL Shortener APIは、連続リクエストを行うと短縮URLが返ってこないケースがあるので、その場合5秒置いて再度リクエストを行う様にしています。


出力結果

f:id:Yoshiya:20150625091717j:image

f:id:Yoshiya:20150625091718j:image

f:id:Yoshiya:20150625092500j:image
1741件の処理にかかった時間は、806秒でした。


追記 2015.07.03

Tinyurlで短縮URLを出力するVBAコードを見つけましたので、上記のコードを変更してみました。
TinyurlはAPIキーが無くても利用できます。

Create Tiny URLs using VBA・Create Tiny URLs using VBA

' 回答プログラム(質問番号:1435032470)・TinyURL Ver.
' Author Y.Yoshiya
' Date 2015/07/03

Option Explicit

Sub main()
 
    Dim BeforeURL As String
    Dim AfterURL As String
    Dim MAXROW As Integer
    Dim lp As Integer
    Dim StartTime, EndTime As Date

    Dim ErrFlag As Boolean

    Application.ScreenUpdating = False

    StartTime = Time

    With Worksheets(1)
    
        MAXROW = .Range("C" & Rows.Count).End(xlUp).Row

        ErrFlag = False
        Do While (1)
            lp = 2
            Do While lp <= MAXROW
                BeforeURL = .Range("C" & lp).Value

                If .Range("D" & lp).Value = "" Then
                    AfterURL = GetTinyURL(BeforeURL)
                    .Range("D" & lp).Value = AfterURL
                End If
                
                If AfterURL = "" Then
                    ErrFlag = True
                End If
                lp = lp + 1
            Loop

            If ErrFlag = False Then
                Exit Do
            End If
        Loop
          
    End With

    EndTime = Time
    Debug.Print "StartTime = ", StartTime & vbCrLf & "EndTime = ", EndTime & vbCrLf & "Time =", DateDiff("s", StartTime, EndTime)

    Application.ScreenUpdating = True
   
End Sub


Function GetTinyURL(url As String) As String
 
    Dim xml As Object
    Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
 
    If xml Is Nothing Then Exit Function

    xml.Open "POST", "http://tinyurl.com/api-create.php?url=" & url, False
    xml.Send
 
    GetTinyURL = xml.responsetext
 
End Function


出力結果

f:id:Yoshiya:20150703023133j:image

f:id:Yoshiya:20150703023134j:image

f:id:Yoshiya:20150703023135j:image




http://firestorage.jp/download/b1aa458a30621cca4e19308786f340a04d82ac67
http://firestorage.jp/download/89634fd6b29efa1a674969730c0ab7305a1dba1c

2015-05-25(Mon) 質問番号:1432429697

[][]質問番号:1432429697


エクセル2010でご教示いただきたいことがあります。
1つのセルの合計に2つの数字のそれぞれの合計を出すことは可能でしょうか。
(むちゃくちゃな質問で申し訳ないですm(_ _)m)
例として画像を添付しますので、これで伝われば幸いです。
よろしくお願いします。
f:id:Yoshiya:20150525001725j:image:w400


回答

' 回答プログラム(質問番号:1432429697)
' Author Y.Yoshiya
' Date 2015/05/25

Option Explicit

' AddCell : 指定範囲のセルから数値を取得(カッコ外とカッコ内)、合計を計算する。
' 書式 : AddCell(指定範囲のセル)
' 戻り値 ; カッコ外の数値合計 & "(" & カッコ内の数値合計 & ")"
'    (カッコ内の数値のフォーマットは小数点第一位まで表示)

Function AddCell(Rng As Range) As Variant

    Dim Total1 As Long
    Dim Total2 As Single
    Dim CellArea As Range
    Dim Element As Range
    Dim Sprit As Integer

    Set CellArea = Rng
    Total1 = 0
    Total2 = 0

    For Each Element In CellArea
    
        If Len(Element) > 0 Then
            Sprit = InStr(Element, "(")
            If Sprit > 0 Then
                Total1 = Total1 + Val(Left(Element, Sprit - 1))
                Total2 = Total2 + Val(Mid(Element, Sprit + 1, Len(Element) - 1))
            Else
                Total1 = Total1 + Val(Element)
            End If
        End If
            
    Next Element

    AddCell = Total1 & "(" & Format(Total2, "#.0") & ")"

End Function

ユーザー定義関数(AddCell)を標準モジュールに作成する。 合計を出したいセルにAddCell関数を記述する。

f:id:Yoshiya:20150525001726j:image:w400