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

関数でもできるけど、ＶＢＡでやってみました。

vbastudy_28.xls
こちらをダウンロードして、開きます。

ツール→マクロ→Visual Basic Editorと開き、

みたいなボタンをクリック。

罫線、右寄せも同時にやってます（＾＾）

プログラムはこんな感じ。

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

こんな感じにしたいのかな？(^^;

まず、A列が通勤手段だとします。

A列に「自動車」という文字列や「自動二輪」という文字列が含まれていた場合、「値を切り取って」とあるんですけど、この「切り取る」ってどう切り取るのか、よくわからないですね。。。
 
「含まれていた場合、=から後ろの文字列を切り取る」
ということでいいのかな？

だとすると、B列の自動車の列の計算式は、B2だったら、

 
C列の自動二輪の列の計算式は、C2だったら、

 
でいいのかな？

まず、SEARCH関数でそれぞれの文字がA列に入っているかどうかを調べ、
入っていない場合は#VALUE!というエラーになるので、ISERROR関数を使用して
それを調べ、エラーだったら　""　、つまり、何も表示させない。
エラーじゃなかった場合、つまり文字列が見つかった場合は、MID関数でA列から文字列を抜き出すというふうになっています。
抜き出す位置は、A列から、「=」を探して、その次の文字から、A列の最後の文字まで、としました。

なぜ質問者さんが「自動」という文字で探そうとしているのかがよくわからないのですが。。。(^^;

なお、A列に「自動車」と「自動二輪」が両方含まれている場合や、「=」が入っていない、また「=自動車=マーチ」みたいな感じで値が入っていた場合は、この式ではだめですね。

こちらにアップしておきます→vbastudy_27.xls

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

とりあえず、

Excelのシート上のボタンを押すと、指定したURLのページの天気の画像と、最高気温を取ってみたいと思います。

ここんとこよく取り上げてる「スクレイピング」ですね。

こないだやったのは、

VBAのお勉強　住所の文字列→緯度・経度を求める

これは文字から緯度・経度を取ってくる、ってものでした。

今回は、固定のページから指定した部分を抜き出してくる、ということで前よりは簡単そうです。

ただ、「画像を抜き出したい」とのことなので、それはこの前とはちょっと違いますね。

まず、HTMLのソースを取ってきてみます。

こないだのYahoo!のトップを取ってくるのと同じですね。URLが違うだけです。

実行してみると、

ん、取れてるようです（＾＾）

天気と最高気温の部分はどこかな？

このあたりですね。

まず、簡単なほう、最高気温のほうから取ってみます。

ソースを見てみると、

<small>15℃</small>

の部分の「℃」の文字が一番最初に出てくるのが、この最高気温の部分のようです。

ということは、ソースの中から「℃」を探して、その前の数字の部分（>の後ろのから℃の前まで）が最高気温、ということになりそうです。

「℃」の位置を求めるには、いつものInstrでよさげです。

実行してみると

実行するときの状況によって値は異なると思いますが、私が取り込んだ時点では7954文字目に「℃」があるようです。

次は、その前の 「>」の位置を調べなければいけないんですが。。。

「>」は、ソースの中にいっぱいありますから、単純に　Instr　では求められません。

この場合、後ろから文字を探す、InStrRevが使えそうです。

最初から「℃」までを抜き出した文字列を作り、その文字の後ろから「>」を探す、って感じですね。

nukidashiという変数に、先頭から「℃」までの文字列を代入して、

InStrRev(nukidashi, ">")　でnukidashiの後ろから「>」を探しています。

saikoukionに、「>」の次の文字以降の文字列を取ってくる、という風にしています。

実行してみると、

ん、取れました（＾＾）

後は、これをセルに代入すればいいですね。これは後でまとめてやります。

次、天気なんですけど。「画像を取りたい」ってことなので、流れとしては、画像をダウンロードして、

その画像をシートに貼り付ける、って感じでいいのかな？

まずソースの中から画像の部分を探してみます。

この辺ですね。この「<img src=・・・・>」の部分を取ってくればいいんですが。

ソース全体でみれば、<img>タグは他にもいっぱいあるので、簡単には探せませんね。

ということで、この近辺をなんとか抜き出して、その中で<img>を抜き出す、ってことで。

全体のソースをみると、「今日の天気」という文字列は、この部分で初めて出てくるようです。

ということは、全体のソースから「今日の天気」を探し、そこ以降の文字列を抜き出し、その中で最初に出てくる<img>を抜き出せばよさげです。

こんな感じになります。

画像のURLを取ってくるところまで書いちゃいましたが、

・まず、「今日の天気」以降を抜き出します。

・次に、その文字列から「<img 」を探し、それ以降の文字列を抜き出します。

・次に、その文字列から　「 " 」（src="の部分です）を探し、その文字の次の文字以降の文字列を抜き出します。

・最後に、その文字列から 「"」（src=の終わりの"です）を探し、その文字の前の文字までを抜き出します。

実行すると、こんな感じ。

取れました（＾＾）

後は、このURLの画像を貼り付ければいいんですが、、、画像のダウンロードってどうやるのか？

「excel vba ファイルをダウンロード」

で検索して見つかった、こちらのページからリンクされていた、こちらのページの説明がわかりやすかったです。

ということで、こんな感じ。

もう、全部作っちゃいました（＾＾；）。コメントが入ってますので、それを見ればどこで何をやってるかは分かると思います。

このファイルがあるドライブのルートディレクトリにtenki.gifという名前で画像を保存して、それをシートに貼り付ける、というふうになっています。なので、tenki.gifというファイルがあったら、上書きされちゃいますので実行するときは注意してください。

実行すると、こんな感じ

ん、できました（＾＾）

ここに置いておきます→vbastudy_26

ショッピングカートやネットショッピングモールなどからお客様からの注文内容がメールで送られてくるような時、その内容をExcelなどにコピー＆ペーストなどで貼り付けている方もいらっしゃると思います。

Excel＋αのソフトで、メールを自動的に取り込んで、エクセルのセルに貼り付ける仕組みのサンプルをつくってみました。

こちらのページからどうぞ

前回の続きです。

↓

B列、C列の両方の項目を見て、重複しているものは最初のものを残して削除する、という感じです。

プログラムです。

前回のプログラムとそんなに変わりません。チェックする項目を変数２つに入れ、その値を両方ともチェックしていくという方法ですね。

実行すると、こんな感じ。

ん、うまいこと消えました（＾＾）ここに置いておきます。→vbastudy_25

こんな感じで、チェックしたい項目が増えれば、同じように変数に代入して、その値をチェックする、、、とすればよいですね。

このブログのリファラーを見ていると、あいかわらず「VBA Excel 重複行」で検索されてくる方が多いですね。

みなさん、そんなに重複行をどうにかしたいのでしょうか？（＾＾；）

重複行について、今までに書いたのは以下の記事です。

VBAのお勉強 Excelで重複行を探す

こちらは、複数の列で重複している値を探す、というものでした。

VBAのお勉強　VBAでExcelの重複した行を探して表示

こちらは、一つの列の中で重複している値を探す、というものでした。

ただ私の経験で、今までデータの重複行、うんぬんを考えるとき、「重複行をどうしたいのか？」で考えると、一番多いのは、

こんなデータがあったとき、B列で重複している行を１行だけ残して、削除してしまう、つまり、

こうしてしまいたい、という事のような気がします。違いますかね？（＾＾；）

名簿なんかで「同じ人がいたら１行残して後は消す」みたいな処理、多いと思うんですけど。

んで、こういうことをするには、「フィルタ」とかを使うのでしょうけど、あの機能って、いまいちよく分からないんですよね。。。

重複した行を「見えなくする」事や、重複しないデータにして、別の位置に抽出して抜き出す、のは、なんとなく出来たんですが。

あとは並べ替えて、IFを使って前の行と同じ値だったらフラグを立てて、その行を消す。とか。

・・・なんか、余計な項目を作ったり、別のところに書き出したり、並べ替えたりするの、めんどくさいんですよね（＾＾；）

自分がやりたいのは、「重複してる行を１行残して、削除する」という事です。

これってエクセルの機能で一発でできないんでしょうか？（＾＾；）

08/4/10 追記
Excel2007には、これを実現させる機能があるようですね。
こちらのサイトにその機能の詳細がのっています

ということで、VBAで書いてみます。

今回はB列の値をみて、

• 重複していない行は、そのまま残す
• 重複している行は、一番先頭の行を残して、残りは削除する

という条件でやってみます。

先頭から１行ずつ、最後の行の前まで見ていきます。

今見てる行の次の行以下を最後の行まで探し、もし今見てる行と同じ値があったら、見つけたほうの行を削除する、という考えかたです。人間が手作業で削除するのと同じですね。

削除した場合、全体の行数が減るのと、次にチェックすべき行（プログラムの j の変数）が１行上に来るので、それも減らす、という感じです。

実行してみると、、、

ん、重複行がなくなりました（＾＾）

とりあえず、ここに置いときます。→vbastudy_24
今回は重複をチェックする対象が、B列だけでした。

これを、

↓

といったように「住所」「名前」の両方が重複している場合削除する、といったように、複数の列をチェックの対象にすることもプログラムを変更すれば可能です。これは次回にやります。

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

例えば、

こんな、Excelファイルがあった時、B列に緯度、C列に経度を入れる。。。

緯度・経度を求めるには、例えばYahoo!さんなんかでは、APIが公開されてます。

ローカルサーチAPI
こちらを使えば、住所の文字列で問い合わせれば、結果がXMLで返ってきます。

その中に緯度・経度も含まれますので、そこからうまく抜き出せば、おっけいですね。

Googleさんでも、APIがあるみたいです。

Google Maps API
で、やはり、同じようにXMLで返ってくる？ようです。

これらを使えば、うまく出来そう（＾＾）、、、なんですが。

ちょっと気になっているのが、例えば、Yahoo!さんの場合、
http://developer.yahoo.co.jp/map/

のページによると、Yahoo!地図情報Webサービスの利用について

• 限られた人、コンピュータによるアクセスのみ認めているサイトでのご使用
• 企業、官公庁その他の団体におけるイントラネット内でのご使用
• 地図の使用によりユーザーから利益を得ていると認められるサイトでのご使用

ってあるんですよね。。。

これって、このAPIを使って、住所→緯度経度を求めるプログラムを作った場合、その仕組みはおそらくローカルのネットワークから使うであろう物（外部にこの仕組みを公開するわけではない）だと思いますので、規約に違反しないのかな？
http://developer.yahoo.co.jp/terms/の利用規約を見てみても、（太字はこちらでつけました。）

利用者は、Yahoo! JAPANのAPI に関するコメント、ノウハウ、方法論、プロシジャ、技術、データやYahoo! JAPANのAPIを使用して開発したアプリケーションを、Yahoo!デベロッパーネットワークのコミュニティーに掲載するなど不特定多数の他の利用者がアクセスできるようにしなければならず、これをもって、Yahoo! JAPANに対して、利用者に対する通知および利用者の権利表示をすることなく、日本の国内外において、無償で非独占的にそれらを使用する（複製、公開、送信、頒布、譲渡、貸与、翻訳、翻案を含む）権利を許諾（サブライセンス権を含む）したものとみなします。また、利用者は、Yahoo! JAPANのAPI に関するコメント、ノウハウ、方法論、プロシジャ、技術、データやYahoo! JAPANのAPIを使用して開発したアプリケーションについて、著作者人格権を行使しないものとします。

（＾＾；）難しい事書いてありますが、ようするに、

「APIを使ったアプリケーションは、外部から誰もが使える仕組みにしないと駄目」

っていってるような気がします。

最終的にこの機能を用いて作成した住所と地図が入ったWebページを公開することにはなりますが、、、
この仕組み自体を公開しないと駄目なんじゃないかな？

もちろんWebサーバー上で、住所の文字列をCGIに渡して、そこからAPIを呼んで結果のXMLを取り込み、そこから地図を出す。みたいな流れであれば、全く問題ない使い方だとは思いますが。。。

これは、Googleさんでも同じ？なのかな？

http://code.google.com/intl/ja/apis/maps/signup.html によると、やはり、

エンドユーザーが自由にアクセスできるサービスを提供してください。

ってあるんですよね。。。

というわけで、Excel→API→Excelって流れは、なんとなくまずいような気がします。（実際はどうだか分かりませんが）

09/05/12追記
こちらの記事に、googleさんの利用について詳細な内容があります。
誰からもアクセスできる事、デスクトップアプリケーションの場合はそのアプリケーションが誰でも利用できること、って事でいいのかな？

Yahoo!さんの場合、http://www.alpsmap.jp/asp/api.htmlで同等のサービスで有料のものはあります。
Googleさんの場合も、http://www.google.com/enterprise/maps/で同じようなことが出来るようです。

これらを使えば、もちろん問題はないでしょう。

。

。

。

といって、、、これであきらめちゃうのもなぁ。

http://map.yahoo.co.jp/から、「東京都新宿区西新宿二丁目８番１号」で検索すれば、

って、出ます。この検索結果の「東京都新宿区西新宿2丁目8-1」のURLを見てみると、

　
　

http://map.yahoo.co.jp/pl?p=%C5%EC%B5%FE%C5%D4%BF%B7%BD%C9%B6%E8%C0%BE%BF%B7

%BD%C9%C6%F3%C3%FA%CC%DC%A3%B8%C8%D6%A3%B1%B9%E6&
lat=35.68627083&lon=139.69494083&type=&gov=13104.67.2.8.1
　
　

・・・lat　lon　これって、緯度、経度なんですよね。この値を取ってくれば。。。

APIは使ってないし、公開されてる情報だからどう加工しても問題ないですよね？（＾＾；）＞Yahoo!さん。

というわけで、APIは使わずにYahoo!地図情報を使ってみたいと思います。

考え方はJavaScriptとかでやってた「スクレイピング」ですね。

まずは、VBAからインターネット上のリソースをURLを指定して取ってくる方法を調べてみます。

「VBA WEB HTMLを取得」で検索すると、こちらのページが見つかりました。その中に紹介されていたこちらのページがわかりやすかったです。

とりあえず、VBAから、Yahoo!のトップのHTMLのソースを取ってきて、イミディエイトウィンドウに表示してみます。

　
Sub test()
Dim oHttp As Object
Set oHttp = CreateObject("MSXML2.XMLHTTP")
oHttp.Open "GET", "http://www.yahoo.co.jp/", False
oHttp.Send
Debug.Print oHttp.responseText
End Sub

実行してみると、

ん、表示しきれてませんが、取れているようです（＾＾）

では今度はYahoo!地図情報から「東京都新宿区西新宿二丁目８番１号」で検索したときのHTMLのソースを表示してみます。

http://map.yahoo.co.jp/から、「東京都新宿区西新宿二丁目８番１号」で検索した結果のURLは、

　
　

http://search.map.yahoo.co.jp/search?q=&p=%C5%EC%B5%FE%C5%D4%BF%B7%BD%C9%B6

%E8%C0%BE%BF%B7%BD%C9%C6%F3%C3%FA%CC%DC%A3%B8%C8%D6%A3%B1%B9%E6
&gc=&rsmode=map&ei=euc-jp&type=　
　
　

ですので、これを与えてみます。

Sub test()
 Dim oHttp As Object
 Set oHttp = CreateObject("MSXML2.XMLHTTP")
 oHttp.Open "GET", "http://search.map.yahoo.co.jp/search?q=&p=%C5%EC%B5%FE%C5%D4%BF%B7%BD%C9%B6%E8%C0%BE%BF%B7%BD%C9%C6%F3%C3%FA%CC%DC%A3%B8%C8%D6%A3%B1%B9%E6&gc=&rsmode=map&ei=euc-jp&type=", False
 oHttp.Send
 Debug.Print oHttp.responseText
End Sub

実行すると、、、長い結果のソースが取得できます。

ところどころに「 ? 」となっているのは、おそらく文字コードが違うからでしょうが、今回欲しい情報の部分は関係なさげです。

のあたりに、

ってありますね（＾＾）。この情報を抜き出せばよさそうです。

こういうの、抜き出すのはやっぱり正規表現を使うべき、だとは思うのですが、やはり、参照設定とかあんまり好きじゃないので（＾＾；）　泥臭い方法でやってみます。

といっても、取ってきたソースの中から、lat=の部分とlon=の部分を探してくるだけですから、そんなに難しくありません。

Sub test()

Dim lat As String
Dim lon As String

Dim nukidashi As String

Dim oHttp As Object
Set oHttp = CreateObject("MSXML2.XMLHTTP")
oHttp.Open "GET", "http://search.map.yahoo.co.jp/search?q=&p=%C5%EC%B5%FE%C5%D4%BF%B7%BD%C9%B6%E8%C0%BE%BF%B7%BD%C9%C6%F3%C3%FA%CC%DC%A3%B8%C8%D6%A3%B1%B9%E6&gc=&rsmode=map&ei=euc-jp&type=", False
oHttp.Send

'とりあえず、nukidashiに、「lat=」以降の文字列を入れます。

nukidashi = Mid(oHttp.responseText, InStr(oHttp.responseText, "lat=") + 4)

'次の「&」までがlatです。

lat = Mid(nukidashi, 1, InStr(nukidashi, "&") - 1)

'nukidashiを「lon=」以降の文字列にします。

nukidashi = Mid(nukidashi, InStr(nukidashi, "lon=") + 4)

'次の「&」までがlonです。

lon = Mid(nukidashi, 1, InStr(nukidashi, "&") - 1)

Debug.Print "緯度"; lat
Debug.Print "経度"; lon

End Sub

実行してみると、

ん、取れました（＾＾）

後は、ExcelのA列に入ってる文字列をURLに与えて、取ってきたデータを、B列、C列に戻す、って感じですね。

・・・って、どうやってURLを求めればいいんでしょうか？（＾＾；）
「東京都新宿区西新宿二丁目８番１号」で検索した結果のURLは、

http://search.map.yahoo.co.jp/search?q=&

p=%C5%EC%B5%FE%C5%D4%BF%B7%BD%C9%B6%E8%C0%BE%BF%B7%BD%C9%C6%F3%C3%FA%CC%DC%A3%B8%C8%D6%A3%B1%B9%E6
&gc=&rsmode=map&ei=euc-jp&type=
　
　

長いので途中で改行しましたが、この赤い部分の「p=」で始まる部分が、「東京都新宿区西新宿二丁目８番１号」を表しているようです。
ということは、この文字列を作り出さないといけない、って事ですね。
どうやらこの文字列は、「東京都新宿区西新宿二丁目８番１号」をeuc-jpでエンコードしたもののようです。

こちらのページで、「東京都新宿区西新宿二丁目８番１号」で、euc-jpで変換してみると、

ん、確かにp=で与えている文字列になってます。

では、この文字を作ればいいのか、、、とはいえ、Excelって、基本的にはShift-JISなので、Shift-JISからEUCに変換しないといけませんね。

「VBA　SJIS EUC 変換」で検索すると、こちらのサイトが見つかりました。
こちらのサイトを参考に、Shift-JIS→EUCの部分を組み込んでみたいと思います。

Sub test()

    Dim lat As String
    Dim lon As String

    Dim nukidashi As String
    Dim eucurlencode As String

    Dim oHttp  As Object
    Set oHttp = CreateObject("MSXML2.XMLHTTP")

    eucurlencode = getEUC("東京都新宿区西新宿二丁目８番１号")

    Debug.Print "pの文字列は" + eucurlencode

    oHttp.Open "GET", "http://search.map.yahoo.co.jp/search?q=&p=" + eucurlencode + "&gc=&rsmode=map&ei=euc-jp&type=", False
    oHttp.Send

    'とりあえず、nukidashiに、「lat=」以降の文字列を入れます。

    nukidashi = Mid(oHttp.responseText, InStr(oHttp.responseText, "lat=") + 4)

    '次の「&」までがlatです。

    lat = Mid(nukidashi, 1, InStr(nukidashi, "&") - 1)

    'nukidashiを「lon=」以降の文字列にします。

    nukidashi = Mid(nukidashi, InStr(nukidashi, "lon=") + 4)

    '次の「&」までがlonです。

    lon = Mid(nukidashi, 1, InStr(nukidashi, "&") - 1)

    Debug.Print "緯度"; lat
    Debug.Print "経度"; lon
End Sub

Function getEUC(CHK_DATA)
    'http://www.ken3.org/asp/backno/asp107.html を使わせていただきました。

    Dim n As Integer
    Dim strWORK As String
    Dim strCODE As String
    Dim P As String
    Dim sEUC As String

    For n = 1 To Len(CHK_DATA)
      strWORK = Mid(CHK_DATA, n, 1)
      strCODE = Hex(Asc(strWORK))
      If Len(strCODE) <= 2 Then
        If strWORK = " " Then
          P = P & "+"
          Else
          P = P & strWORK
        End If
      Else
        sEUC = SJIStoEUC(strCODE)
        P = P & "%" & Mid(sEUC, 1, 2) & "%" & Mid(sEUC, 3, 2)
      End If
    Next

    getEUC = P

End Function

Function SJIStoEUC(strSJISCODE)
    'http://www.ken3.org/asp/backno/asp107.html を使わせていただきました。
    Dim hi
    Dim lo

    'シフトJISコードの上位バイトを hi、下位バイトを lo とします。
    hi = CLng("&h" & Mid(strSJISCODE, 1, 2))
    lo = CLng("&h" & Mid(strSJISCODE, 3, 2))

    If hi <= &H9F Then
      hi = hi - &H71 'hi が 0x9f 以下の場合、 hi から 0x71 減じます。
    Else
      hi = hi - &HB1 'そうでない場合、 hi から 0xB1 減じます。
    End If

    'hi に 2 を乗じて、さらに 1 を加えます。
    hi = hi * 2 + 1

    'lo が 0x7F より大きい場合、 lo から 1 減じます。
    If lo > &H7F Then lo = lo - 1

    'lo が 0x9E 以上の場合、lo から 0x7D 減じて、hi に 1 加えます。
    If lo >= &H9E Then
        lo = lo - &H7D
        hi = hi + 1
    Else 'そうでない場合、 lo から 0x1F 減じます。
        lo = lo - &H1F
    End If

    'JISの hi と lo ができたので、0x80 を or して 最上位のビットを立てます。
    hi = hi Or &H80
    lo = lo Or &H80

    '結果を返します
    SJIStoEUC = Right("0" & Hex(hi), 2) & Right("0" & Hex(lo), 2)

End Function

getEUC、SJIStoEUCのいずれも、http://www.ken3.org/asp/backno/asp107.htmlを参考に（ほぼ丸写しですが）、作成させていただきました。
とりあえず、「東京都新宿区西新宿二丁目８番１号」を求めるようにしてあります。
実行してみると、

　　ん、きちんと変換できてますね（＾＾）

では、最後です。いつものようにA列を全行みて、B,C列に値を入れてみます。

]
Sub test()

    Dim lastgyou As Integer
    Dim i As Integer

    Dim lat As String
    Dim lon As String

    Dim nukidashi As String
    Dim eucurlencode As String

    Dim oHttp  As Object
    Set oHttp = CreateObject("MSXML2.XMLHTTP")

    'A列の最終行の行番号を求めます
    lastgyou = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

    For i = 1 To lastgyou

        'A列の値で検索します
        eucurlencode = getEUC(ActiveSheet.Cells(i, 1).Value)

        oHttp.Open "GET", "http://search.map.yahoo.co.jp/search?q=&p=" + eucurlencode + "&gc=&rsmode=map&ei=euc-jp&type=", False
        oHttp.Send

        '取得した結果をnukidashiに入れます
        nukidashi = oHttp.responseText

        'もし、nukidashiに、「lat=」 と「lot=」が含まれていた場合

        If InStr(nukidashi, "lat=") <> 0 And InStr(nukidashi, "lot=") <> 0 Then

        'とりあえず、nukidashiに、「lat=」以降の文字列を入れます。

        nukidashi = Mid(oHttp.responseText, InStr(oHttp.responseText, "lat=") + 4)

        '次の「&」までがlatです。

        lat = Mid(nukidashi, 1, InStr(nukidashi, "&") - 1)

        'nukidashiを「lon=」以降の文字列にします。

        nukidashi = Mid(nukidashi, InStr(nukidashi, "lon=") + 4)

        '次の「&」までがlonです。

        lon = Mid(nukidashi, 1, InStr(nukidashi, "&") - 1)

        '結果をB列、C列に代入します。

        ActiveSheet.Cells(i, 2).Value = lat
        ActiveSheet.Cells(i, 3).Value = lon

        End If

    Next i

End Sub

Function getEUC(CHK_DATA)
    'http://www.ken3.org/asp/backno/asp107.html を使わせていただきました。

    Dim n As Integer
    Dim strWORK As String
    Dim strCODE As String
    Dim P As String
    Dim sEUC As String

    For n = 1 To Len(CHK_DATA)
      strWORK = Mid(CHK_DATA, n, 1)
      strCODE = Hex(Asc(strWORK))
      If Len(strCODE) <= 2 Then
        If strWORK = " " Then
          P = P & "+"
          Else
          P = P & strWORK
        End If
      Else
        sEUC = SJIStoEUC(strCODE)
        P = P & "%" & Mid(sEUC, 1, 2) & "%" & Mid(sEUC, 3, 2)
      End If
    Next

    getEUC = P

End Function

Function SJIStoEUC(strSJISCODE)
    'http://www.ken3.org/asp/backno/asp107.html を使わせていただきました。
    Dim hi
    Dim lo

    'シフトJISコードの上位バイトを hi、下位バイトを lo とします。
    hi = CLng("&h" & Mid(strSJISCODE, 1, 2))
    lo = CLng("&h" & Mid(strSJISCODE, 3, 2))

    If hi <= &H9F Then
      hi = hi - &H71 'hi が 0x9f 以下の場合、 hi から 0x71 減じます。
    Else
      hi = hi - &HB1 'そうでない場合、 hi から 0xB1 減じます。
    End If

    'hi に 2 を乗じて、さらに 1 を加えます。
    hi = hi * 2 + 1

    'lo が 0x7F より大きい場合、 lo から 1 減じます。
    If lo > &H7F Then lo = lo - 1

    'lo が 0x9E 以上の場合、lo から 0x7D 減じて、hi に 1 加えます。
    If lo >= &H9E Then
        lo = lo - &H7D
        hi = hi + 1
    Else 'そうでない場合、 lo から 0x1F 減じます。
        lo = lo - &H1F
    End If

    'JISの hi と lo ができたので、0x80 を or して 最上位のビットを立てます。
    hi = hi Or &H80
    lo = lo Or &H80

    '結果を返します
    SJIStoEUC = Right("0" & Hex(hi), 2) & Right("0" & Hex(lo), 2)

End Function　

　
　ループでまわすのはいつもどおりです。A列の値をとって、緯度経度を求め、B列、C列に代入します。
また、検索した結果、「lat=」「lot=」がない場合は無視します。
実行すると、、、

ん、値は入りました（＾＾）
この値を使って、地図を表示させてみると、、、
http://map.yahoo.co.jp/pl?type=static&lat=35.68627083&lon=139.69494083...
http://map.yahoo.co.jp/pl?type=static&lat=35.60133333&lon=140.12643806...
http://map.yahoo.co.jp/pl?type=static&lat=35.44441889&lon=139.64586389...
上３つ、東京都庁、千葉県庁、神奈川県庁の住所から得られたURLです。

ん、とりあえずおっけいかな？

もちろん、これはYahoo!できちんと該当する住所が検索されなければ出ませんし、仮に住所を入れて検索した結果、複数の候補があった場合、最初に出てきたlat= lon=を抜き出しますので、それ以降は無視されます。

とりあえず、こちらにアップしておきます。→vbastudy_23

以下の記事を参考に、「注文メールの内容をサーバーから受信しExcelに取り込む仕組みのサンプル」という記事を作成しています。よろしかったらどうぞ（＾＾）

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

この手の「人間の代わりに自動的に処理する」系のプログラムは、好きだなぁ（＾＾；）

まず、このメールがどのような状態なのかがわからないので（テキストファイル？xlsの中に貼り付けてある？）

質問者さんの作られたプログラムを見てみると。。。

Set FR = Range(Selection, Cells(Rows.Count, Selection.Column).End(xlUp)).Find("*[商品]*", , xlValues)

ん、使ったことのない命令ばかり（＾＾；）

まず、Findから見ていきます。

「VBA Excel Find」で検索すると。。。こちらのページが分かりやすかったです。

Rangeオブジェクト（範囲を表すオブジェクト）から、条件に当てはまるセルを探す、というメソッドらしいです。

"*[商品]*" となっていますから、おそらく、「　[商品]　」という値を含むセルを探す、ということでしょうか？

３つめのパラメータは「xlValues」となっていますが、検索の対象を指定しているとの事です。この場合、セルの値で探す、という事ですね。

んじゃ、どの範囲を探すのか？が、前のRange( ) で指定されている、、、どこになるんだろ？（＾＾；）

Rangeってのは、どうやって指定してるのか？「VBA Excel range」で検索すると、、こちらのページが見つかりました。

Rangeはプロパティで、Range(最初のセル,最後のセル)ってことらしいです。

最初のセル：Selection

最後のセル：Cells(Rows.Count, Selection.Column).End(xlUp)

ってことらしいです。

・・・Selectionってなんだろうか？（＾＾；）　たぶん、今選択しているセルのことだろうけど。。。

「VBA Excel selection」で検索。こちらのページが見つかりました。。。ActiveCellみたいな物らしいですが、

Ｓｅｌｅｃｔｉｏｎの場合は複数のセルを選択しているときは、セルの範囲を返すようです。

うーん、、、よくわからないですが、今選択されているセルから、その列のデータの一番最後の行までを見てるって感じなのかな？

ということで。

こんな感じにシートに貼り付けたメールの文章で、今選択しているセル（上の例では「Ａ1」）から下に、最終行まで見ていくってことにしてみます。

とりあえず、プログラムです。

Sub test()
    Dim DB(35)             As Variant
    Dim imamiterugyou      As Integer
    Dim imamiterugyou_atai As String
    Dim fromgyou           As Integer
    Dim lastgyou           As Integer
    Dim shouhinmei_shouhinbangou_color_size As String
    Dim shouhinbangounukidashi As String
    Dim color As String
    Dim size As String
    
    '商品を代入する変数を空にしておきます。
    DB(13) = ""
    DB(14) = ""
    
    
    '今選択しているセルの行を求めます。
    fromgyou = ActiveCell.Row
    
    '今選択しているセルの最終行を求めます。
    lastgyou = ActiveSheet.Cells(ActiveSheet.Rows.Count, ActiveCell.Column).End(xlUp).Row
    
    '今見ている行を設定します。最初は、fromgyouです。
    imamiterugyou = fromgyou
    
    Do
        
        '今見てる行の値をimamiterugyou_ataiに入れます。
        imamiterugyou_atai = ActiveSheet.Cells(imamiterugyou, ActiveCell.Column)
        
        '今見ている行の値の内容によって、処理を分けます。
        If imamiterugyou_atai = "[備考]" Then
            
            'もし、今見てる行が[備考]なら,次の行から
            '[ショップ名]が先頭から始まる行の前までをDB(25)に追加していきます。
            Do
            
                '今見てる行を１行下にします。
                imamiterugyou = imamiterugyou + 1
                
                '今見てる行の値を変数に代入します。
                imamiterugyou_atai = ActiveSheet.Cells(imamiterugyou, ActiveCell.Column)
                
                'もし今見てる行が「　[ショップ名]　」で始まるなら、備考は終わりなのでループから抜けます。
                If InStr(imamiterugyou_atai, "[ショップ名]") = 1 Then Exit Do
                
                'DB(25)に今見てる行の値を追加します。
                DB(25) = DB(25) + imamiterugyou_atai
            
            Loop While imamiterugyou <= lastgyou
        
        ElseIf imamiterugyou_atai = "[配送日時指定]" Then
                    
            'もし、今見てる行が[配送日時指定]なら、DB(22)に値を入れます。
            
            'まず、２行下の時間とスペースを入れます。
            DB(22) = ActiveSheet.Cells(imamiterugyou + 2, ActiveCell.Column) + " "
            '次に、１行下の日付を入れます。
            DB(22) = DB(22) + ActiveSheet.Cells(imamiterugyou + 1, ActiveCell.Column)
        
            '片方しか値が入っていない場合のために、半角スペースをTrimします
            DB(22) = Trim(DB(22))
            
            '今見てる行を３行下にします。
            imamiterugyou = imamiterugyou + 3
        
        ElseIf InStr(imamiterugyou_atai, "[送付先]") = 1 Then
        
            'もし今見てる行の先頭が「　[送付先]　」の場合、
            'まず、「　[送付先]　」の文字列以降を取り出します。
        
            imamiterugyou_atai = Mid(imamiterugyou_atai, 6)
            
            'DB(30)に漢字の姓名を入れます。半角かっこの「 ( 」の１文字前をTrimしたものとします。

            DB(30) = Trim(Mid(imamiterugyou_atai, 1, InStr(imamiterugyou_atai, "(") - 1))
            
            'DB(31)に姓名のフリガナを入れます。半角かっこで囲まれた部分とします。
            DB(31) = Mid(imamiterugyou_atai, InStr(imamiterugyou_atai, "(") + 1, InStr(imamiterugyou_atai, ")") - InStr(imamiterugyou_atai, "(") - 1)
            
            '次の行に郵便番号、住所が入っているとします。
            imamiterugyou = imamiterugyou + 1
            
            '今見てる行の値を変数に代入します。
            imamiterugyou_atai = ActiveSheet.Cells(imamiterugyou, ActiveCell.Column)
        
            '郵便番号は、この行の２文字目から、最初の半角スペースの前までとします。
            DB(32) = Mid(imamiterugyou_atai, 2, InStr(imamiterugyou_atai, " ") - 2)
                    
            '住所は、最初の半角スペースの後ろとします。
            DB(33) = Mid(imamiterugyou_atai, InStr(imamiterugyou_atai, " ") + 1)
        
            '次の行に電話番号が入ってるとします。
            imamiterugyou = imamiterugyou + 1
            
            '今見てる行の値を変数に代入します。
            imamiterugyou_atai = ActiveSheet.Cells(imamiterugyou, ActiveCell.Column)
        
            '電話番号は、この行の７文字目以降とします。
            DB(34) = Mid(imamiterugyou_atai, 7)
        
        ElseIf imamiterugyou_atai = "[商品]" Then
        
            '以下、商品の抜出です。
            '今見てる行を１行下にします。
            imamiterugyou = imamiterugyou + 1
        
        
            Do
                '色とサイズの変数を空にします。
            
                color = ""
                size = ""
                
                '１行目の商品名（商品番号＋カラー＋サイズ）の行をshouhinmei_shouhinbangou_color_sizeに代入します。
                shouhinmei_shouhinbangou_color_size = ActiveSheet.Cells(imamiterugyou, ActiveCell.Column)
            
                '今見てる行を１行下にします。
                imamiterugyou = imamiterugyou + 1
                
                Do
                    '今見てる行の値を変数に代入します。
                    imamiterugyou_atai = ActiveSheet.Cells(imamiterugyou, ActiveCell.Column)
                    
                    'もし、今見ている行が、「 価格 」から始まる行ならば、ループから抜けます
                    If InStr(imamiterugyou_atai, "価格") = 1 Then Exit Do
                
                    'もし、今見てる行が、「カラー:」から始まる行ならば、colorにカラーを入れます。
                    If InStr(imamiterugyou_atai, "カラー:") = 1 Then
                        
                        color = Mid(imamiterugyou_atai, 5)
                    
                    End If
                
                    'もし、今見てる行が、「サイズ:」から始まる行ならば、sizeにサイズを入れます。
                    If InStr(imamiterugyou_atai, "サイズ:") = 1 Then
                        
                        size = Mid(imamiterugyou_atai, 5)
                    
                    End If
                
                    '今見てる行を１行下にします。
                    imamiterugyou = imamiterugyou + 1
                
                Loop While imamiterugyou <= lastgyou
            
                '商品番号を抜き出します。商品番号は、shouhinmei_shouhinbangou_color_sizeのかっこの内側
                'の文字列の後ろについているカラーとサイズを省いた部分です。
                                
                '取りあえず、「(」より後ろの文字を抜き出します。
                shouhinbangounukidashi = Mid(shouhinmei_shouhinbangou_color_size, InStr(shouhinmei_shouhinbangou_color_size, "(") + 1)
                '最後の「)」を除きます。
                shouhinbangounukidashi = Mid(shouhinbangounukidashi, 1, Len(shouhinbangounukidashi) - 1)
            
                'カラーとサイズの文字数文だけ、後ろを削除します。
                shouhinbangounukidashi = Mid(shouhinbangounukidashi, 1, Len(shouhinbangounukidashi) - Len(color + size))
                
                'DB(13)に連結します。
                
                DB(13) = DB(13) + IIf(DB(13) <> "", ",", "") + shouhinbangounukidashi
                
                
                '今見ている価格の行から、個数を抜き出します。
                'まず、「x 」から後ろの文字列を抜き出します。
                imamiterugyou_atai = Mid(imamiterugyou_atai, InStr(imamiterugyou_atai, "x ") + 2)
                
                '次に、「(」より前の文字列を抜き出します。これが個数です。
                imamiterugyou_atai = Mid(imamiterugyou_atai, 1, InStr(imamiterugyou_atai, "(") - 1)
            
                'DB(14)に連結します。
                DB(14) = DB(14) + IIf(DB(14) <> "", ",", "") + shouhinmei_shouhinbangou_color_size + "x " + imamiterugyou_atai
            
                
                Do
                    '今見てる行を１行下にします。
                    imamiterugyou = imamiterugyou + 1
                
                    '今見てる行の値を変数に代入します。
                    imamiterugyou_atai = ActiveSheet.Cells(imamiterugyou, ActiveCell.Column)
            
                    'もし、その行が*********************************************************************だったら、ループから抜けます。
                    If imamiterugyou_atai = "*********************************************************************" Then Exit Do
                    'もし、その行が----------だったら、ループから抜けます。
                    If imamiterugyou_atai = "----------" Then Exit Do
            
            
                Loop While imamiterugyou <= lastgyou
                
                'もし、今見た行が*********************************************************************だったら、ループから抜けます。
                If imamiterugyou_atai = "*********************************************************************" Then Exit Do
            
                '今見てる行を１行下にします。
                imamiterugyou = imamiterugyou + 1
            
            Loop While imamiterugyou <= lastgyou
        
        Else
            
            '今見てる行を１行下にします。
            imamiterugyou = imamiterugyou + 1
        End If
    
    Loop While imamiterugyou <= lastgyou
    
    If DB(13) = "" Then MsgBox "商品が見つかりません", 48: Exit Sub
    If DB(30) = "" Then MsgBox "送付先が見つかりません", 48: Exit Sub
    
    Debug.Print "DB(13)="; DB(13)
    Debug.Print "DB(14)="; DB(14)
    Debug.Print "DB(22)="; DB(22)
    Debug.Print "DB(25)="; DB(25)
    Debug.Print "DB(30)="; DB(30)
    Debug.Print "DB(31)="; DB(31)
    Debug.Print "DB(32)="; DB(32)
    Debug.Print "DB(33)="; DB(33)
    Debug.Print "DB(34)="; DB(34)

End Sub

（＾＾；）ひたすら長っ・・・
とりあえず、実行結果は、以下のとおり。

ん。いいんでないかい？（＾＾）

ただし、、、これで完成とはいえません。
どのようなメールの文面でも正確に抜き出せるか、というと、今サンプルで出ているメールの文面であれば問題ないですが、

例えば、
・漢字の姓名欄に半角のかっこが入っていた場合（それ以降をフリガナとみなします）
・郵便番号がない場合
・住所や、名前、電話番号が複数行で入っている場合
・備考の内容が　「[ショップ名]」から始まる文字列が入っていた場合（本来の備考として取り込めない行が発生します）
・今出ている行以外に余計な行があった場合（出来るだけ無視するようにしてありますが、、）

など、こちらで想定していない形のデータがきた場合は、うまく抜き出せません。

とりあえず、こちらに置いときます。→vbastudy_22

このブログ、WordPressを使っているんですが。

いろんなプラグインを試しては、外したりして。

アクセス解析に、「ShortStat」を入れたり、「SlimStat」を入れたりしてたんですが。
phpMyAdminで見てみると、今は使ってないプラグインのテーブルがあるなぁ。。
使ってないのは消すか。。。

いらなそうなテーブルを選んで。。。

削除、と。

ん、Ok。

・

・

・

（＾＾；）　ＯＫじゃない・・・・・・（＾＾；）

普段、phpMyAdminをほとんど使わないので（たまにテーブルの中身を確認するくらい）、使い方をよく把握していませんでした。

ということで、、、全部消えた・・・・（＾＾；）

やばい（＾＾；）・・・・

ほとんどアクセスもない、貧弱な記事とはいえ、ここんとこいっぱい更新してたので、その時間が全て無になる・・・

頭真っ白（＾＾；）・・・・言葉を失う、とはこの事だ。

もちろん、バックアップなんて取っといてないし（というか、バックアップの仕方も知らないし（＾＾；））

・

・

・

データベースが消えただけなので、Webサーバー上には、使ってたプラグインやテーマのファイル、アップロードした画像などのファイルは残ってましたが。。。肝心の記事が入ったデータがないわけで・・・

１時間くらい、呆然としてました（＾＾；）

なんとか、なんとか復旧できないか。

Yahoo!で検索「MySQL drop database 復旧」　出てくるのは業者ばっかり（＾＾；）

はてなで「mysql drop」で検索。こちらのページが見つかりましたが、「ファイルシステム復旧」。。。

消えたＭｙＳＱＬのファイルを復旧させれば、何とかなるかも、って感じですね。

「Linux ファイル削除　復旧」、、、業者か、「復旧するのは難しい」、「バックアップを取っておけ」とかとか。。。

・・・

あきらめるかなぁ、、、金を出してまで復旧させたい内容ではないし、、、ここらへんで「自己満足ブログをやめろ」という神の啓示なのかなぁ、、、

えーい、あきらめきれん（＾＾；）

サーバーに、何かログとか残ってないかな？

「mysql ログ」で検索。「バイナリログ」ってのがあるらしい。。。

そういえば、phpMyAdminにも「バイナリログ」とかいう項目があったような。。。

開くと、、、

おおぉぉ、なんかそれらしいサイズのファイルが！開いてみると。。。

（＾＾）Wordpressを初めて使ってからのSQL文が残っているようです（＾＾）

ということは、このSQL文をなんとか引っ張り出せれば、記事の内容も復元できるかも。。。

とりあえず、このバイナリログをバックアップしておき、WordPress自体を再インストール。

空のデータベースが出来上がった状態で、記事を復元していきます。

以下、私の行った手順です。これで正常に動作するかどうかは不明ですが、今のところ私の環境では正常に動作しています。

1. タイトルだけの記事を公開します。
2. phpMyAdminでwp_postsのファイルの中に追加された行のＩＤを、以前投稿したときのＩＤに直します。
3. バイナリログから拾った、最終更新のUPDATE文を加工して、必要な項目だけをUPDATEします。
4. ダッシュボードから内容を確認します。

バイナリログから拾い出したUPDATE文は、ブラウザに表示されたものをそのままでは使えませんでした（改行が反映できない）。なぜか私の環境では　mysqlbinlog　でバイナリログをダンプしようとするとエラーになってしまうので、サーバー上の mysql コマンドラインで、-teeオプションを使用して、ログをテキストファイルに書き出し、show binlog eventを使って、バイナリログをテキストファイルに書き出しました。

こうして、なんやらかんやらで、ようやく復旧できました。。。（＾＾；）

仕事上のトラブルではなくて、よかった。。。今後の教訓にしたいと思います。

http://okwave.jp/qa3915562.html

こんなファイルだとします。

 ピンク色のところが変わったら、黄色いところを自動的に集計する。。。こないだやったイベントですね（＾＾）

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row = 4 And (Target.Column = 5 Or Target.Column = 7 Or Target.Column = 9 Or Target.Column = 11) Then
        MsgBox ("ピンクのところが変わったよ")
    End If
End Sub

Targetで、変わったところを判断して、４行目でかつ、（EまたはGまたはIまたはK）が変わったらメッセージ、と。

 ピンクのところを変えてみると

ん、おっけい。

ピンクが変わったら何をするか？下の集計を行う前に、いったん黄色のところを全部消しましょう。

 これもやったばっかり（＾＾）

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row = 4 And (Target.Column = 5 Or Target.Column = 7 Or Target.Column = 9 Or Target.Column = 11) Then
        ActiveSheet.Range("E5:L10").Clear
    End If
End Sub

範囲を指定して　.Clear　でクリアーです。ピンクの値を変えてみると。。。

（＾＾；）値は消えましたが、罫線や背景色も消えちゃいました（＾＾；）

値だけ消したいんだけど、どうすればよいかな。。。

Yahoo!で、「Excel セル 値を消去」で検索すると、こちらのページが見つかりました。

 .ClearContentsで消せばいいみたいですね。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row = 4 And (Target.Column = 5 Or Target.Column = 7 Or Target.Column = 9 Or Target.Column = 11) Then
        ActiveSheet.Range("E5:L10").ClearContents
    End If
End Sub

 いったん値と罫線、背景色を戻します。 で、ピンクを変えてみます。

ん、おっけい（＾＾） 後は黄色の部分を作っていく、って事で。

 ここの考え方、結構複雑なので、とりあえずプログラムです。

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim kaime As Integer
     Dim nokori_shikomiryou As Long
     Dim nokori_lotsuuryou As Long
     Dim suuryou As Long
     Dim imamiteru_lotnogyousuu As Integer
     Dim imano_kiironogyousuu As Integer
     'もし、ピンク色のところが変更されたら
     If Target.Row = 4 And (Target.Column = 5 Or Target.Column = 7 Or Target.Column = 9 Or Target.Column = 11) Then
         '黄色のところの値を全部クリアします。
         ActiveSheet.Range("E5:L10").ClearContents
         '表１を3行目（「A1」のロット）から見ていきます。
         imamiteru_lotnogyousuu = 3
         '1回目から見ていきます。
         kaime = 1
         '残りの仕込量を変数に代入
         nokori_shikomiryou = ActiveSheet.Cells(4, (kaime - 1) * 2 + 5)
         'ロットの数量を変数に代入
         nokori_lotsuuryou = ActiveSheet.Cells(imamiteru_lotnogyousuu, 2)
         '黄色の列の最初の値を5にします。
         imano_kiironogyousuu = 5
         Do
             'もし、残りの仕込量が0なら、終了
             If nokori_shikomiryou = 0 Then Exit Do
             'データの表示。ロット名の表示
             ActiveSheet.Cells(imano_kiironogyousuu, (kaime - 1) * 2 + 5).Value = ActiveSheet.Cells(imamiteru_lotnogyousuu, 1)
             'データの表示。数量の表示
             suuryou = IIf(nokori_shikomiryou >= nokori_lotsuuryou, nokori_lotsuuryou, nokori_shikomiryou)
             ActiveSheet.Cells(imano_kiironogyousuu, (kaime - 1) * 2 + 6).Value = suuryou
             '今表示した数量を、それぞれから引く
             nokori_shikomiryou = nokori_shikomiryou - suuryou
             nokori_lotsuuryou = nokori_lotsuuryou - suuryou
             imano_kiironogyousuu = imano_kiironogyousuu + 1
             'もし、仕込量が0なら次へ進む
             If nokori_shikomiryou = 0 Then
                 imano_kiironogyousuu = 5
                 kaime = kaime + 1
                 nokori_shikomiryou = ActiveSheet.Cells(4, (kaime - 1) * 2 + 5)
                 'もし、残りの仕込量が0なら、終了
                 If nokori_shikomiryou = 0 Then Exit Do
             End If
             'もし、ロットの残量がない場合、次のロットへ進む
             If nokori_lotsuuryou = 0 Then
                 imamiteru_lotnogyousuu = imamiteru_lotnogyousuu + 1
                 nokori_lotsuuryou = ActiveSheet.Cells(imamiteru_lotnogyousuu, 2)
                 'もし、ロットの数量が0の場合、もうロットがないので終了
                 If nokori_lotsuuryou = 0 Then
                     MsgBox ("全部のロットを使っても足りませんでした。")
                     Exit Do
                 End If
             End If
         Loop
     End If
End Sub

（＾＾；）今までで一番難しいかな？

手作業で黄色い部分を作っていく場合と考え方は同じなんですけどね。

終了判断をするところのプログラムがちょっと汚い感じですが。。。

もし、質問があれば、コメント欄でどぞ。ファイルはこちらにおいておきます。→vbastudy_21.xls