2015-07-23

質問番号：1437189907

人力検索 VBA

Excelのマクロを使って2つの住所の直線距離を求めたいです。
今、Sheet1のA1セルに、大阪にある通天閣の住所が記載されております。
A2セルに四天王寺、A3セルに大阪城と、周辺のスポットの住所が記載されています。
そういうスポット情報が、A2セルから2万行ぐらいあります。
この状況から、A1セルの通天閣の住所と、各セルの住所の直線距離を調べ、その距離をB列などに出力するような。
そんな処理がもし可能でしたら、お教えいただきたいのですが。
2点間の距離を調べられるサイトは多く見つけられたのですが、一度に処理できる方法を見つけることが出来ませんでして。
よろしくお願い致します。

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

http://developer.yahoo.co.jp/webapi/map/openlocalplatform/v1/geocoder.html
デベロッパーネットワークトップ > YOLP(地図) > Yahoo!ジオコーダAPI（Yahoo! JAPAN)
http://vldb.gsi.go.jp/sokuchi/surveycalc/api_help.html
測量計算サイト > API使用法 > 距離と方位角の計算（入力パラメータ）

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

参考サイト

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
２点間の直線距離がわかる距離計算サイト（株式会社プロネット）

回答

' 回答プログラム（質問番号：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 >= "０" And strChar <= "９") Or (strChar >= "Ａ" And strChar <= "Ｚ") Or (strChar >= "ａ" And strChar <= "ｚ") Then
            strRet = strRet & StrConv(strChar, vbNarrow)
        Else
            strRet = strRet & strChar
        End If
    Next lp
   
    AscEx = strRet

End Function

出力結果

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

追記

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

参考サイト

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 API は Google マップ上の結果表示と組み合わせる場合にのみ使用できます。地図に表示せずにジオコーディングの結果だけを利用することは禁止されています。許可されている使用方法の詳細については、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の利用制限についてですが、１アプリケーションIDにつき最大50000回／1日だそうです。
1ユーザーで最大１０個のアプリケーションIDが取得できるそうなので、最大利用すると1日に500000回までWEB APIが利用できそうです。

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

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

2015-06-25

質問番号:1435032470

人力検索 VBA

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

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

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

処理前手順

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

APIキーの取得・Google Maps API入門
　　（上記のサイトではGoogle MAPを利用する為のAPIキー取得方法を解説していますが、Google URL ShortenerもAPIキーの取得方法は同じです。）

（Google URL Shortenerのリクエスト回数は100万回／1日の制限があります。）

回答

' 回答プログラム（質問番号：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秒置いて再度リクエストを行う様にしています。

出力結果

（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

出力結果

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

2015-05-25

質問番号:1432429697

人力検索 VBA

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

回答

' 回答プログラム（質問番号：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関数を記述する。

2015-05-18

質問番号:1431837793

人力検索 VBA

VBAのことで質問です。
一覧表の特定の列に半角スペースまたは全角スペースのみで入力されているものがあればその行をClearContentsをしたいと思っています。
Criteria1に"* *"や"*　*"と入力するとスペースが含まれる全てのレコードが抽出されてしまいます。
色々な組み合わせを作ってFor文で繰り返し行うくらいしかないのでしょうか？
192,000行もあるので、なるべくFor文は使いたくありません。

回答

' 回答プログラム（質問番号：1431837793）
' Author Y.Yoshiya
' Date 2015/05/18

Option Explicit

Sub main()

Dim LastRow As Long

Dim lp1 As Long
Dim lp2 As Integer
Dim Flag As Boolean

    If Worksheets.Count = 1 Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
    End If

    LastRow = Me.Range("A" & Rows.Count).End(xlUp).Row

    For lp1 = 1 To LastRow
        Flag = False
        For lp2 = 1 To Len(Me.Range("A" & lp1))
            If Mid(Me.Range("A" & lp1), lp2, 1) <> " " And Mid(Me.Range("A" & lp1), lp2, 1) <> "　" Then
                Me.Range("A" & lp1).EntireRow.Copy
                Worksheets(2).Range("A" & lp1).EntireRow.PasteSpecial (xlPasteAll)
                Flag = True
                Exit For
            End If
        Next lp2
            
        If Flag = False Then
            Worksheets(2).Range("A" & lp1).EntireRow.ClearComments
        End If
    Next lp1

End Sub

サンプルプログラムではA列を対象にしている。　A列以外の列を対象にする場合は、"A"を対象列に変更する。

2015-04-18

質問番号:1429329438

人力検索 VBA

指定の文字列を含むセルのみ、左から60文字以上の文字列を削除したい。
今、次のようなデータがA列の1行目からズラリと並んでいるとします。

-

aaa
bbb
ccc
【長い】abcdefgggggggggggggggggggggggggggh
ddd
eee
fff
・
・
・
・
・

-

15000行ほどです。
ここにおきまして、上記のように“【長い】”という文字列を含むセルがいくつかあります。
そのセルだけを、“【長い】”という4文字分も含めまして、合計で左から60文字だけにしたいのです。
61文字以上の文字は削除したいのです。
関数およびマクロ等で効率的に処理する方法等、もしありましたらご教授いただきたい次第です。
よろしくお願い致します。

回答

' 回答プログラム（質問番号：1429329438）
' Author Y.Yoshiya
' Date 2015/04/18

Option Explicit

Sub main()

Dim LastRow As Long
Dim CellString As String

Dim lp1 As Long

    If Worksheets.Count = 1 Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
    End If

    LastRow = Me.Range("A" & Rows.Count).End(xlUp).Row
    
    For lp1 = 1 To LastRow
        If InStr(Me.Range("A" & lp1), "【長い】") > 0 Then
            CellString = Left(Me.Range("A" & lp1), 60)
            Worksheets(2).Range("A" & lp1) = CellString
        Else
            Worksheets(2).Range("A" & lp1) = Me.Range("A" & lp1)
        End If
    
    Next lp1

End Sub

テストデータ作成用プログラム

' テストデータ作成プログラム（質問番号：1429329438）
' Author Y.Yoshiya
' Date 2015/04/18

Option Explicit

Sub main()

Dim CharCount As Integer
Dim CellString As String

Dim lp1 As Long
Dim lp2 As Integer

    For lp1 = 1 To 10000
        CharCount = Int(Rnd * 200) + 20
    
        CellString = ""
        For lp2 = 1 To CharCount
            CellString = CellString & Chr(Int(Rnd * 62) + 65)
        Next lp2
    
        If Int(Rnd * 100) < 10 Then
            CellString = "【長い】" & CellString
        End If
    
        Me.Range("A" & lp1) = CellString
    Next lp1

End Sub

ダウンロードURL

http://firestorage.jp/download/d2d9fb645c88b5a75561891bebd19312dab6ecb6

2014-12-22

質問番号:1419196732

人力検索 VBA

置換対象が同一列にあってうまく置換できません。
今、画像のようにデータが並んでおりまして。
北東→南東
北西→南西
南東→北東
南西→北西
南→北
北→南
東→西
西→東
と、置換したいのですが。
例えば、普通に北東を南東に置換した
場合、既に北東であったものは南東になりますが。
次に南東を北東に置換しようとした際、最初から南東であったものだけでなく、置換処理を行った後の南東も、北東になってしまうという状況でして。
何とか、同時に一気に置換できるような関数やマクロはないでしょうか。
あるいは、置換処理を行ったものについては、置換対象にしないような工夫というのでしょうか。
サンプルファイルはこちら http://xfs.jp/sBZskc に置きました。
よろしくお願い致します。

回答１　VBAで変換（シート１に記述）

Option Explicit

Sub main()

Dim lp As Long              ' カウンタ
Dim RowCount As Long        ' 最終行

    RowCount = Range("A" & Rows.Count).End(xlUp).Row

    For lp = 1 To RowCount
        If Range("A" & lp) <> "" Then
            Select Case Range("A" & lp)
                Case "北"
                    Range("B" & lp) = "南"
                Case "南"
                    Range("B" & lp) = "北"
                Case "東"
                    Range("B" & lp) = "西"
                Case "西"
                    Range("B" & lp) = "東"

                Case "北西"
                    Range("B" & lp) = "南西"
                Case "北東"
                    Range("B" & lp) = "南東"
                Case "南西"
                    Range("B" & lp) = "北西"
                Case "南東"
                    Range("B" & lp) = "北東"
            End Select
        End If
    Next lp

End Sub

回答２　ユーザー関数で変換（標準モジュールに記述）

Function ChangeDirection(Direction As String) As String

    Select Case Left(Direction, 1)
        Case "北"
            ChangeDirection = Replace(Direction, "北", "南")
        Case "南"
            ChangeDirection = Replace(Direction, "南", "北")
        Case "東"
            ChangeDirection = Replace(Direction, "東", "西")
        Case "西"
            ChangeDirection = Replace(Direction, "西", "東")
    End Select

End Function

（変換したいセルにユーザー関数を挿入）

回答２' 回答２で作ったユーザー関数を用いてVBAで変換

Option Explicit

Sub main()

Dim lp As Long              ' カウンタ
Dim RowCount As Long        ' 最終行

    RowCount = Range("A" & Rows.Count).End(xlUp).Row

    For lp = 1 To RowCount
        If Range("A" & lp) <> "" Then
            Range("B" & lp) = ChangeDirection(Range("A" & lp))
        End If
    Next lp

End Sub

（ChangeDirection関数はシート１、標準モジュールどちらに記述しても可）

回答３　エクセル関数で変換

=IF(A2="","",IF(LEN(A2)=2,IF(A2="北西","南西",IF(A2="北東","南東",IF(A2="南西","北西","北東"))),IF(A2="北","南",IF(A2="南","北",IF(A2="東","西","東")))))

（以下B列にコピー）

ダウンロードURL

http://firestorage.jp/download/6d260d6db7fbae8c7131f4110359362efbcd338c

2014-12-10

質問番号：1418207622

VBA

A列とB列を比較して同じデータがあれば「1回だけ」B列の該当データに色を付けるようなマクロや関数をお教えいただきたいです。 Add Star
図のように、一致するデータに色を付けたいのですが、それを1回限りにして、B列に余計なデータがないかどうか調べたいのです。
類似の方法でも構いません。（A列とB列を比較し、一致するデータがあればC列に、B列の該当セルの個数を出す等）
実際のデータはA列、B列共に、1500行ぐらいまで入っております。
お力添えいただければ幸いです。
よろしくお願いします。

サンプルシートのA列は列番号（範囲：1〜1500 重複無し）をセット。
B列は乱数関数（rand関数）を数式にセット（範囲：1〜2000 重複有り）

Option Explicit

Sub main()

Dim lp1, lp2 As Long        ' カウンタ
Dim ARow, BRow As Long      ' 最終行

    ' サンプルシートをコピー
    If Worksheets.Count = 1 Then
        Worksheets(1).Copy After:=Sheets(1)
    End If

    ' コピーしたシートで処理
    With Worksheets(2)
        ARow = .Range("A" & Rows.Count).End(xlUp).Row   ' A列最終行
        BRow = .Range("B" & Rows.Count).End(xlUp).Row   ' B列最終行

        ' A列セルの内容とB列セルの内容が一致した場合、B列セルの背面色を黄色に変更
        For lp1 = 1 To ARow
            For lp2 = 1 To BRow
                If .Range("A" & lp1) = .Range("B" & lp2) Then
                    .Range("B" & lp2).Interior.Color = vbYellow
                    Exit For
                End If
            Next lp2
        Next lp1
    End With

End Sub

ダウンロードURL

http://firestorage.jp/download/41309a2c79537901fc29b78a7efea1b3c668a4d7

回答

出力結果

追記

処理前手順

回答

出力結果

追記 2015.07.03

出力結果

回答

回答

回答

テストデータ作成用プログラム

ダウンロードURL

回答１ VBAで変換（シート１に記述）

回答２ ユーザー関数で変換（標準モジュールに記述）

回答２' 回答２で作ったユーザー関数を用いてVBAで変換

回答３ エクセル関数で変換

ダウンロードURL

ダウンロードURL

回答１　VBAで変換（シート１に記述）

回答２　ユーザー関数で変換（標準モジュールに記述）

回答３　エクセル関数で変換