ExcelでGoogleマップを表示する方法

2023/09/05 08:30

このQ&Aのポイント

ExcelでGoogleマップを表示させる方法を解説します
マーカーが一つしか表示されず、2行目までの住所を同時に表示させる方法について質問です
回答をお待ちしています

ベストアンサー

ExcelでGoogleマップを表示する

2013/08/12 02:24

http://news.mynavi.jp/articles/2012/04/24/excelvba/index.html このページのものを参考にして、地図を表示させ、マーカーを表示させるところまではうまくいきましたが、マーカーが一つしか表示されず、2行目までの住所を同時に表示させることができません。どなたか、回答よろしくお願いします。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True Dim xhr As New MSXML2.XMLHTTP Dim tmp As New MSXML2.DOMDocument Dim geo As MSXML2.IXMLDOMNodeList Dim loc As MSXML2.IXMLDOMNode Dim addr As String Dim url As String Dim js As Object Dim coordtmp() As String Dim coord As String Set js = CreateObject("ScriptControl") js.Language = "JScript" addr = js.CodeObject.encodeURIComponent(Target) If addr = "undefined" Then Set js = Nothing: Exit Sub Set js = Nothing '(1)URLエンコードした住所から、ジオコーディングのリクエストを送信する url = "http://maps.google.com/maps/api/geocode/xml?sensor=false&address=" & addr xhr.Open "POST", url, False xhr.send If xhr.StatusText <> "OK" Then Exit Sub '(2)レスポンスから緯度・経度を取り出し、Sheet2の該当セルに設定する tmp.LoadXML (xhr.responseText) Set geo = tmp.getElementsByTagName("geometry") Set loc = geo(0).FirstChild Set xhr = Nothing Sheet2.Range("latitude") = loc.FirstChild.Text Sheet2.Range("longitude") = loc.LastChild.Text Sheet2.Range("targetname") = Target.Offset(0, -2).Value　'追加 '(3)地図を描く RedrawMap End Sub Sub RedrawMap() Dim url As String Dim s As String Dim strType As String s = Sheet2.Range("latitude") & "," & Sheet2.Range("longitude") url = "http://maps.google.com/maps/api/staticmap?size=512x512&sensor=false" url = url & "&center=" & s url = url & "&zoom=" & Sheet2.Range("zoom") url = url & "&markers=color:blue%7Clabel:" & Sheet2.Range("targetname") url = url & "%7C" & s If Sheet2.Range("roadmap") Then strType = "roadmap" If Sheet2.Range("satellite") Then strType = "satellite" If Sheet2.Range("terrain") Then strType = "terrain" If Sheet2.Range("hybrid") Then strType = "hybrid" url = url & "&maptype=" & strType Sheet1.WebBrowser1.Navigate url End Sub

STUDY-01
お礼率65% (78/119)

その他([技術者向] コンピューター)
回答数2
ありがとう数1

みんなの回答 （2）
専門家の回答

質問者が選んだベストアンサー

ベストアンサー

やぎじじい（@yagijijii）
ベストアンサー率56% (63/112)

2013/08/16 11:31 回答No.2

内容からお察しするに、特にプログラムの内容を改変していないのに、動作しないという感じですよね。それならば、情報提供サイトに直接お尋ねするのが良いと思います。ちなみに、私も似たようなものを作っていますので一度お試し下さい。　→エクセルファイルのダウンロードが必要です https://sites.google.com/site/yagijijii/ekuseru-ji/de-tu-maime-rumi

その他の回答 (1)

やぎじじい（@yagijijii）
ベストアンサー率56% (63/112)

2013/08/12 16:03 回答No.1

内容が高度で、解決策を提示できませんが、参考になるかもしれないので・・・＞　マーカーが一つしか表示されず、2行目までの住所を同時に表示させる＞　ことができません。この内容についてですが、以下の(1)と(2)のどちらでしょうか。あるいは、違う内容でしょうか。 (1)１行目の住所だけはＯＫだが、２行目以降の住所ではすべて失敗する。 (2)例えば、３行目と５行目と９行目の住所を同時に表示したいのであるが、　どれかひとつしか表示できない。 (1)であればプログラム上の問題であり、(2)であればそれは仕様だと思います。以上、中途半端な回答で申し訳ありません。

質問者

補足 2013/08/12 18:54

すみません。今回は(1)に該当します。1行目の住所しか地図上にでません。

関連するQ&A

Excel VBA 引数が2個のマクロの呼び出し方
ExcelのVBAで、シート上のボタンがクリックされた時に呼び出すマクロ(プロシージャ)の引数が1個の時は、コード1のようにできましたが、引数が2個ある時は、コード2のように記述しても、ボタンをクリックするとエラーになりますが、【？】の部分をどのように記述すればよいのでしょうか。 (Windows10,Excel2010) -------------------コード1---------------------------------------- Sub test1() 　Dim row As Integer 　Dim wave_file_path As String 　For row = 1 To 2 　　wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value 　　Call ボタン作成(row, wave_file_path) 　Next row End Sub Sub ボタン作成(ByVal row As Integer, ByVal wave_file_path As String) 　Dim cell_loc As String 　cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address 　ThisWorkbook.Worksheets("Sheet1").Select 　With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _ 　　Range(cell_loc).Top, _ 　　Range(cell_loc).Width, _ 　　Range(cell_loc).Height) 　　.name = "ボタン_" & cell_loc 　　.OnAction = "'WAVE_PLAY """ & wave_file_path & "" & "'" 　　.Characters.Text = "再生" 　End With End Sub Sub WAVE_PLAY(ByVal wave_file_path As String) 　If Dir(wave_file_path) = "" Then 　　MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation 　　Exit Sub 　End If 　Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path End Sub ------------------------------------------------------------------- -------------------コード2---------------------------------------- Sub test2() 　Dim row As Integer 　Dim wave_file_path As String 　For row = 1 To 2 　　wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value 　　Call ボタン作成(row, wave_file_path) 　Next row End Sub Sub ボタン作成(ByVal row As Integer, ByVal wave_file_path As String) 　Dim cell_loc As String 　cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address 　ThisWorkbook.Worksheets("Sheet1").Select 　With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _ 　　Range(cell_loc).Top, _ 　　Range(cell_loc).Width, _ 　　Range(cell_loc).Height) 　　.name = "ボタン_" & cell_loc 　　.OnAction = "'WAVE_PLAY """ & wave_file_path & "" & "," & row & "'" <==【？】　　.Characters.Text = "再生" 　End With End Sub Sub WAVE_PLAY(ByVal wave_file_path As String, ByVal row As Integer) 　If Dir(wave_file_path) = "" Then 　　MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation 　　Exit Sub 　End If 　Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path 　ThisWorkbook.Worksheets("Sheet1").Cells(row, 4).Value = "再生済" End Sub -------------------------------------------------------------------
- 締切済み
- Excel（エクセル）
Excel シートにボタンを作成するVBA
ExcelシートのA列にWAVEファイルのフルパス名が書かれている状態で、このWAVEファイルを再生するボタンをC列に作成するVBAを作りたいのですが、ボタンが押されたときに実行されるプロシージャに引数がないときは、コード1のようにすればできますが、ボタンが押されたときに実行されるプロシージャに引数があるときは、コード2のように記述してもエラーになりますが、どのように記述すればよいのでしょうか。(Windows10,Excel2010) '-----------------コード1------------------------------------------ Sub test() 　Dim row As Integer 　Dim wave_file_path As String 　row = 1 　wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value 　Call 再生ボタン作成(row, wave_file_path) End Sub Sub 再生ボタン作成(ByVal row As Integer, ByVal wave_file_path As String) 　Dim cell_loc As String 　cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address 　ThisWorkbook.Worksheets("Sheet1").Select 　With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _ 　　Range(cell_loc).Top, _ 　　Range(cell_loc).Width, _ 　　Range(cell_loc).Height) 　　.name = "ボタン_" & cell_loc 　　.OnAction = "WAVE_PLAY" 　　.Characters.Text = "再生" 　End With End Sub Sub WAVE_PLAY() 　Dim wave_file_path As String 　wave_file_path = "Z:\Document\4_Data\CD_DVD_USB\USB_20200222\REC\JBP001\JBP00101.WAV" 　If Dir(wave_file_path) = "" Then 　　MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation 　　Exit Sub 　End If 　Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path End Sub '------------------------------------------------------------------- '-------------------コード2---------------------------------------- Sub test() 　Dim row As Integer 　Dim wave_file_path As String 　For row = 1 To 100 　　wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value 　　Call 再生ボタン作成(row, wave_file_path) 　Next row End Sub Sub 再生ボタン作成(ByVal row As Integer, ByVal wave_file_path As String) 　Dim cell_loc As String 　cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address 　ThisWorkbook.Worksheets("Sheet1").Select 　With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _ 　　Range(cell_loc).Top, _ 　　Range(cell_loc).Width, _ 　　Range(cell_loc).Height) 　　.name = "ボタン_" & cell_loc 　　.OnAction = "WAVE_PLAY " & wave_file_path ' <====　◆ここでエラーになります◆ 　　.Characters.Text = "再生" 　End With End Sub Sub WAVE_PLAY(ByVal wave_file_path As String) 　If Dir(wave_file_path) = "" Then 　　MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation 　Exit Sub 　End If 　Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path End Sub '-------------------------------------------------------------------
- ベストアンサー
- Excel（エクセル）
エクセルでマクロの進行状況を表示あるには
下記のマクロはURLからタイトルを抽出するものなのですが件数が何千件とあり、進行状況が分かれば便利かなと思います。表示方法はどのような形でも構わないのですが、ご教授願います。色々調べたのですがうまくいかず困っております。ちなみに私は全くの度素人であり、マクロもネット上で検索して見つけたものをそのまま使用しております。－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Private Sub CommandButton1_Click() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A2") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send With CreateObject("ADODB.Stream") .Open .Type = 2 'adTypeText .Charset = "unicode" .Writetext Http.ResponseBody .Position = 0 .Charset = "utf-8" buf = .ReadText() .Close End With 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function Private Sub タイトル抽出_Click() End Sub －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－宜しくお願い致します。
- ベストアンサー
- Visual Basic
エクセルで１００以上のシートからデータを読み込むのに時間がかかり困っています
エクセル２００３でAuto_Open時にデータの更新をしてみましたが、一々画面を読んでしまい時間がかかってしまいます。まだコードがよく理解できていませんので、どなたかよい方法を教えてください。コードは以下のようです。シートは１８０あり、一覧表にシート名の表を作りました。よろしくお願いします。 Sub Auto_Open() 'シートオープンで一覧表のデータ更新 '変数の宣言 Dim MyDA As Integer Dim MyDB As String Dim MyDC As String Dim MyDD As String Dim MyDE As String Dim MyDF As String Dim MyDG As String Dim MyDH As String Dim MyDI As String Dim MyDJ As String Dim MyDK As String For MyDA = 3 To 173 '一覧表を呼びシート名の代入 Worksheets("一覧表").Activate MyDB = Range("T" & MyDA).Value '必要なデータの代入 Worksheets(MyDB).Activate MyDC = Range("J3").Value MyDD = Range("J4").Value MyDE = Range("B6").Value MyDF = Range("F6").Value MyDG = Range("K6").Value MyDH = Range("C9").Value MyDI = Range("B8").Value If MyDI = "" Then MyDI = "-" End If MyDJ = Range("F8").Value If MyDJ = "" Then MyDJ = "-" End If MyDK = Range("K8").Value If MyDK = "" Then MyDK = "-" End If Sheets("一覧表").Activate Range("B" & MyDA) = MyDC Range("C" & MyDA) = MyDD Range("D" & MyDA) = MyDE Range("E" & MyDA) = MyDF Range("F" & MyDA) = MyDG Range("G" & MyDA) = MyDH Range("H" & MyDA) = MyDI Range("I" & MyDA) = MyDJ Range("J" & MyDA) = MyDK Next MyDA End Sub
- ベストアンサー
- Visual Basic
Excel VBA 入力規則
入力規則を利用して、３つのセルを連携させることを考えていますが、不適合な値を張り付けらられた場合に拒否をする方法があるのでしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ad As String Dim ma As Range Dim ma2 As Range Dim r As Range Dim r2 As Range Dim r3 As Range Dim r1 As Range Dim m As Long Dim m2 As Long Application.EnableEvents = False If Target = "" Then Range("F7").Validation.Delete Range("F7") = "" If Target.Address(0, 0) = "B7" Then Range("D7").Validation.Delete Range("D7") = "" End If GoTo EXIT_SUB End If With Worksheets("Sheet1") ad = "A4" Set r = .Range(ad) Set ma = r.MergeArea Set r1 = r.Offset(0, 1) m = Application.Match(Range("B7"), .Range(r1, .Cells(r.Row + ma.Count - 1, r1.Column)), 0) Set r2 = .Cells(r.Row + m - 1, r1.Column) Set ma2 = r2.MergeArea If Target.Address(0, 0) = "B7" Then If ma.MergeCells Then setValiS Target.Offset(0, 2), r2 Range("F7").Validation.Delete Target.Offset(0, 2) = "" Target.Offset(0, 4) = "" Else MsgBox "A列が連結されていません。" End If ElseIf Target.Address(0, 0) = "D7" Then Set r3 = r2.Offset(0, 1) m2 = Application.Match(Target, .Range(r3, .Cells(r2.Row + ma2.Count - 1, r3.Column)), 0) setValiS Target.Offset(0, 2), .Cells(r2.Row + m2 - 1, r3.Column) Target.Offset(0, 2) = "" End If End With EXIT_SUB: Application.EnableEvents = True End Sub Sub setVali2() Dim tc As Range Dim c As Range Set tc = Worksheets("登録").Range("D3") Set c = Worksheets("Sheet1").Range("C3") setValiS tc, c End Sub Sub setValiS(tc As Range, c As Range) Dim ss As String Debug.Print tc.Address, c.Address ss = getChildren(c) If ss > "" Then With tc.Validation .Delete .Add Type:=xlValidateList, Formula1:=getChildren(c) End With End If Worksheets("登録").Activate End Sub Function getChildren(c As Range) Dim c1 As Range Dim ss As String Dim s1 As String Worksheets("Sheet1").Activate ss = "" For Each c1 In c.MergeArea s1 = c1.Offset(0, 1) If s1 <> "" Then ss = ss & "," & s1 Next c1 If ss <> "" Then ss = Mid(ss, 2) Else MsgBox "データがありません！" End If getChildren = ss End Function Sub Outline() Dim CheckRow As Long Dim Moji As String Dim TopRow As Long Dim EndRow As Long With ActiveSheet .Range("A2").ClearOutline .Outline.SummaryRow = xlAbove CheckRow0 = .Range("A" & .Rows.Count).End(xlUp).Row CheckRow = CheckRow0 Do If Moji = "" Then Moji = .Cells(CheckRow, 1).Value EndRow = CheckRow ElseIf yy_mm(CDate(.Cells(CheckRow, 1).Value)) = yy_mm(CDate(Moji)) Then TopRow = CheckRow If TopRow = 1 Then .Rows(TopRow + 1 & ":" & EndRow).Rows.Group Exit Do End If Else .Rows(TopRow + 1 & ":" & EndRow).Rows.Group CheckRow = CheckRow + 1 Moji = "" End If CheckRow = CheckRow - 1 Loop Until CheckRow = 1 .Rows(CheckRow + 1 & ":" & EndRow).Rows.Group .Outline.ShowLevels RowLevels:=1 ExecuteExcel4Macro "SHOW.DETAIL(1," & CheckRow0 & ",TRUE)" End With End Sub Function yy_mm(d As Date) yy_mm = Format(d, "yy/mm") End Function
- 締切済み
- その他（プログラミング・開発）
エクセルでメタタグを抽出するには？
すいません、前回質問した者です。前回の質問では・・・エクセルシートのB列にURLが並んでいるとして、ＶＢＡを使って、C列には「description」D列には「keywords」を抽出したいという質問をしたのですが、参考になる回答がなかったのでもう一度質問します。以前、私が教えてもらったのは、B列にURLが並んでいて、Ａ列にタイトルを抽出させたものでした。それが以下になります。 Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("B1") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, -1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function このような感じでＢ列にはURLの一覧があるとして、Ａ列にタイトル、C列にdescription　D列にkeywordsが抽出できればいいなと考えています。ちなみに、私にはＶＢＡの知識がまったくありません。とりあず、これだけ出来れば、すごく助かるのですが、どなたか教えていただけないでしょうか？　よろしくお願いします！
- ベストアンサー
- Visual Basic
エクセルでURLからタイトルのみを抽出する方法
URLからタイトルを抽出するマクロについて教えて下さい。忍者ブログの記事タイトルをURLから抽出しようとしたのですが文字化けしてしまい全く分かりません。他のサイトやブログだと普通に抽出出来るのですが・・・文字コード？か何かだと思うのですが、原因が分かりません。ちなみに以下のマクロは、ネット上で検索して見つけたものをそのままコピーして使用しています。－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A3") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－宜しくお願い致します。
- ベストアンサー
- Visual Basic
小数点以下表示
averageで計算した値を表示したところ、勝手に四捨五入されてしまいました小数点第二位まで表示したいのでどなたかよろしくお願いいたします<m(__)m> Option Explicit Public Sub 平均() Const SH_NAME As String = "VBA" Dim art As String Dim i Dim ws As Worksheet Dim endrow As Long Dim msg As String Dim writerow As Integer Dim target As Range Dim ActCell As Variant Dim Result As Integer Set ws = ThisWorkbook.Worksheets(SH_NAME) writerow = 2 art = InputBox("日付を入力してください") With ws endrow = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To endrow If art = .Range("A" & i) Then If target Is Nothing Then Set target = Range("D" & i) Else Set target = Union(target, Range("D" & i)) End If Else If InStr(msg, .Range("A" & i)) = 0 Then msg = msg & .Range("A" & i) & vbCrLf End If End If Next i If msg <> "" Then MsgBox msg End If target.Select ActCell = Selection.Address Result = Application.WorksheetFunction.Average(.Range(ActCell)) Range("F39").Value = Result Range("F39").NumberFormatLocal = "0.00" End With End Sub
- ベストアンサー
- Visual Basic
Excel VBAでブラウザのリンクをクリックするには
Excelのバージョンは2003です。 VBAで出発地から到着地からNavitimeのサイトに接続して距離を取得するようなプログラムを作成していますが… 下記のように記述しています。 Private Sub Workbook_Open() Dim ie As InternetExplorer Dim addr0 As String Dim addr1 As String Set ie = CreateObject("InternetExplorer.Application") ie.Visible = True addr0 = "住所1" addr1 = "住所2" ie.navigate "http://www.navitime.co.jp/?keyword0=" & urlEncode(addr0) & _ "&keyword1=" & urlEncode(addr1) & _ "&ctl=0604" Do While ie.Busy = True Do While ie.readyState <> 4 DoEvents Loop Loop End Sub Public Function urlEncode(str As String) As String Set sc = CreateObject("ScriptControl") sc.Language = "Jscript" Set js = sc.CodeObject urlEncode = js.encodeURIComponent(str) End Function リンクをクリックするにはどのようにすればいいのでしょうか。アドバイス宜しくお願いします。
- 締切済み
- Visual Basic
エクセルの簡単なマクロ機能を追加したいのです
既存のエクセルマクロ（Sub チェック()以下です）に下記の内容のマクロを付け足したいです。教えていただけないでしょうか。付け足したい条件です：　Sheet2のC列に　0　があれば　Sheet1のB列に　愛と（[太字]でセルの背景色を[灰色25%]にして）入れたいです恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub
- 締切済み
- その他MS Office製品