- ベストアンサー
正規表現でデーター取得
AKARI0418の回答
- AKARI0418
- ベストアンサー率67% (112/166)
面白そうですねがんばってください！！ Sub 株価取得() Dim oHttp As Object, ws1 As Object, ws2 As Object Dim dthtml As String Dim chktb As String Dim stchk1 As Long Dim stchk2 As Long Dim chksu As Long Dim j As Integer Dim urlweb As String Dim mino As Long, w As Long '追加 Const adTypeBinary As Long = 1 Const adTypeText As Long = 2 Set ws1 = Sheets(1) Set ws2 = Sheets(2) w = 1 mino = ws1.Cells(w, 1) urlweb = URLI & "mino" Set oHttp = CreateObject("Microsoft.XMLHTTP") oHttp.Open "GET", urlweb, False oHttp.Send Dim objStm As Object Set objStm = CreateObject("ADODB.Stream") objStm.Open objStm.Type = adTypeBinary objStm.Write oHttp.responsebody objStm.Position = 0 objStm.Type = adTypeText objStm.Charset = "euc-jp" dthtml = objStm.ReadText() objStm.Close Set objStm = Nothing With CreateObject("VBScript.RegExp") .Pattern = ">([^<>]+)<" .Global = True On Error Resume Next stchk1 = InStr(dthtml, "始値") stchk2 = InStrRev(Left(dthtml, stchk1), "table") chksu = InStr(stchk2, dthtml, "</table") dthtml = Mid$(dthtml, stchk2, chksu) itmsu = .Execute(dthtml).Count ReDim hdat(itmsu) With .Execute(dthtml) For j = 1 To itmsu ws2.Cells(j, 1) = .Item(j).SubMatches(0) Next j End With On Error GoTo 0 End With Set oHttp = Nothing DoEvents End Sub
関連するQ&A
- 正規表現について
ExcelにてVBScriptの正規表現を使用していますが、 理解できないところがあるので、教えてください １．EXCEL VBAにて下記のコードがあります Sub Sample2() Const strCHK As String = "000AAA111BBB2222BBB333" Dim RE, strPattern As String, i As Long, msg As String, reMatch, Item Set RE = CreateObject("VBScript.RegExp") strPattern = "AAA.+bbb" With RE .Pattern = strPattern .IgnoreCase = True .Global = True Set reMatch = .Execute(strCHK) For Each Item In reMatch Debug.Print Item.Value & " FirstIndex→" & Item.FirstIndex & " Length→" & Item.Length Next End With Set reMatch = Nothing Set RE = Nothing End Sub ２．上記を動作させると、イミディエイトに下記が出力されます AAA111BBB2222BBB FirstIndex→3 Length→16 ３．疑問 strPattern = "AAA.+bbb"にて検索しているのに、 AAA111BBBが表示されないのは、何故なのでしょうか？ よろしくお願いします
- ベストアンサー
- その他MS Office製品
- 縦に取得するのを横にする＆最後に取得したところから
下記のマクロで、A1の語句をGoogle検索して、 上位５位のタイトル・URLをA2～A11へ記入できます。 そのA1に語句、A2～A11に上位５位というのを、 A1に語句、B1～K1に上位５位という風に変更したいです。 A1（語句）｜A2（タイトル）｜A3（URL）｜ ↓ A1（語句）｜B1（タイトル）｜C1（URL）｜ という感じです。 もう一つ、 途中でロボットでない証明のクリックがあります。 そのため、マクロを止めざるおえないです。 改めて、マクロを再開する時に、 最後に取得した語句から始めるようにしたいです。 これらは、どのようなマクロの記述になるでしょうか？ EXCEL２０１６です。 よろしくお願いいたします。 '//標準モジュール Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) Dim objIE As SHDocVw.InternetExplorer '参照設定 Microsoft Internet Contorls Dim oHTML As HTMLDocument '参照設定 Microsoft HTML Object Library Sub Main() Dim c As Range Dim enSrTxt As String Dim counter As Long On Error GoTo ErrHandler Const BASEURL As String = "https://www.google.co.jp/search?q=" With ActiveSheet Set objIE = Nothing For Each c In .Range("A1", .Cells(1, Columns.Count).End(xlToLeft)) If c.Value <> "" Then If c.Value Like "*[ぁ-龠]*" Then enSrTxt = EnUtf8(c.Value) Else enSrTxt = c.Value End If Call getIE(BASEURL & enSrTxt) 'Application.Wait TimeSerial(0, 0, 10) '遅くしていた元凶 Sleep 500 counter = counter + 1 End If Next c End With ErrHandler: If Err <> 0 Then MsgBox Err.Description End If End Sub Sub getIE(ByVal strURL As String) Dim cnt As Long Dim cl As Object Dim c As Range Dim nm As Long Set oHTML = New HTMLDocument If objIE Is Nothing Then Set objIE = New SHDocVw.InternetExplorer End If Set c = Cells(2, Columns.Count).End(xlToLeft) '二行目で計る If c.Value <> "" Then nm = c.Column + 1 Else nm = c.Column With objIE .Visible = True .navigate strURL Do While .Busy Or .readyState <> 4: DoEvents: Loop Set oHTML = .document End With Call outputLog(oHTML, nm) Set cl = objIE.document.getElementsByClassName("csb ch") cl(1).Click DoEvents Sleep 500 Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop Set oHTML = objIE.document Cells(1, nm).EntireColumn.AutoFit Application.ScreenUpdating = True End Sub Sub outputLog(oHTML As HTMLDocument, nm As Long) Dim buf As Variant Dim j As Long, i As Long, k As Long Dim gLinks As Object Dim mTitle As Variant Dim cnt As Long j = Cells(Rows.Count, nm).End(xlUp).Row + 1 With oHTML Set mTitle = oHTML.getElementsByClassName("LC20lb") Set gLinks = oHTML.getElementsByClassName("TbwUpd") If gLinks.Length > 0 Then If (gLinks.Length - 1) > 4 Then cnt = 4 Else cnt = gLinks.Length - 1 For i = 0 To cnt '' 5コまで、 Cells(j, nm).Value = mTitle(i).innerText buf = gLinks(i).ParentNode.href If InStr(1, buf, "%") > k Then buf = DecodeUTF8(buf) Cells(j + 1, nm).Value = buf Cells(j + 1, nm).Font.ColorIndex = 4 'フォントの色 j = j + 2 buf = "" Next End If End With End Sub Private Function EnUtf8(ByRef strSource As String) As String 'Encode Dim objSC As Object Set objSC = CreateObject("ScriptControl") objSC.Language = "Jscript" EnUtf8 = objSC.CodeObject.encodeURIComponent(strSource) Set objSC = Nothing End Function Private Function DecodeUTF8(ByVal strSearch As String) 'Decord If strSearch = "" Then Exit Function With CreateObject("ScriptControl") .Language = "JScript" With .CodeObject DecodeUTF8 = .decodeURI(strSearch) End With End With End Function
- 締切済み
- Excel（エクセル）
- 【VBA】【正規表現】
２３歳OLです。 VBAと正規表現についての質問です。 ▼やりたいこと ================================================ 1 | 0 |1234567890 | 2014-2-22 22:22:22.06+09 という数列から 1234567890 という数字のみを抜き出したいです。 正確には２本目の|と３本目の|の間に入っている様々な数字です。 ※桁数が固定されていません。 ================================================ ▼実際書いたコード ================================================ Sub Sample2() Dim RE, strPattern As String, i As Long, msg As String, reMatch Set RE = CreateObject("VBScript.RegExp") strPattern = "☆この部分☆" With RE .Pattern = strPattern .IgnoreCase = True .Global = True For i = 1 To 10 Set reMatch = .Execute(Cells(i, 1)) If reMatch.Count > 0 Then msg = msg & reMatch(0).Value & vbCrLf End If Next i End With MsgBox msg Set reMatch = Nothing Set RE = Nothing End Sub ================================================ ☆この部分に☆に何を入れればよいでしょう？ ご指導よろしくおねがいします。
- ベストアンサー
- Visual Basic
- URLからタイトルを取得したい！
エクセルのＡ列にはURLがずらっとあり、Ｂ列にタイトル取得を考えています。 そこで、他の質問者さんのコードを試しました。 その結果、普通のサイトでは問題なく取得できたのですが、 アメーバーブログなどの無料ブログでは、途中で止まってエラーとなってしまうようです。 どこかいけないのでしょうか？ Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A1") 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
- VBA sheet2データーから平均取得 sheet1へコピー
sheet2指定セルデーターから平均 sheet1指定セルに取得したいのですがうまくいきません。 例 sheet1 sheet2 列A 列B 列C 列A 列B 列C １ ２ 指定 １ ２ ３ １ ２ ３ １ ２ ３ １ ２ ３ １ ２ ３ sheet2・列C１～３の平均を、sheet1・指定セルに取得したいのですが Sub test() Dim r As Long, u As Long, ws1 As Object, ws2 As Object, y As Long r = 10 u = 1 Set ws1 = Sheets(1) Set ws2 = Sheets(2) y = ws1.Range("A" & Rows.Count).End(xlUp).Row Dim myAve As Long myAve = Application.WorksheetFunction.Average(ws2.Range(Cells(3, u), Cells(7, u))) ws1.Cells(r, 7).Value = "myAve" r = r + 1 u = u + 1 End Sub 変数y r u を使いfor～nextでデーターを一括取得するつもりなのですが この段階でうまくいきません。
- ベストアンサー
- Visual Basic
- VBAコードでシート名を取得したい。
下記のコードは、指定したExcelブックにある情報をVBAコードを設置したブックに 情報を取得するコードになります。 質問なんですが・・・指定したExcelブックは、予めSheet名までをVBAコードで指定し、 そのSheetの内容を取得していますが、この部分を指定したSheet名ではなく、 Sheet名を取得し、取得したSheet名から自分で選択したSheetを選んび、 そのSheetの内容を取得する様に変えたいと考えています。 取得する側のSheet名が一定の名前になっていない為、 今までSheet名を変えて情報を取得する様にしていたのを 変えずに情報を取得したいと思ったからなんですが・・・ どの様に変えればできるのか初心者のためよろしくお願いします。 できましたら・・・UserForm2を使ってComboboxに取得するSheet名を 一覧化し、そのComboboxからSheet名を選べる様にしたいと思います。 ----------------------------------------------------------------------------------- Public Day As String '全プロシージャーで有効な変数 Sub CommandButton1() If MsgBox(Space(6) & "メールデータを取込みます。よろしいですか？", vbYesNo, "継続確認") = 7 Then Exit Sub Dim LstWb As Workbook Dim LstWs As Worksheet Dim OutWs As Worksheet Dim LstDt As Variant Dim EndRow As Long Dim Day0 As String Dim Day1 As String Dim i As Long Dim j As Integer Dim k As Long Set LstWb = Workbooks.Open(ThisWorkbook.Path & "\テストファイル.xlsm") Set OutWs = ThisWorkbook.Sheets("Sheet1") Set LstWs = LstWb.Sheets("Sheet1") EndRow = LstWs.Cells(Rows.Count, 1).End(xlUp).Row With LstWs LstDt = .Range(.Cells(1, 1), .Cells(EndRow, 5)) End With LstWb.Close Set LstWb = Nothing Set LstWs = Nothing Load UserForm2 With UserForm2 Day0 = LstDt(2, 4) .ComboBox1.AddItem Day0 For i = 2 To EndRow With .ComboBox1 Day0 = .List(.ListCount - 1) Day1 = LstDt(i, 4) If Day0 <> Day1 Then .AddItem Day1 End If End With Next i .ComboBox1.Value = .ComboBox1.List(0) End With UserForm2.Show For i = 1 To 5 OutWs.Cells(1, i).Value = LstDt(1, i) Next i k = 2 For i = 2 To EndRow Day0 = LstDt(i, 4) If Day = Day0 Then For j = 1 To 5 OutWs.Cells(k, j).Value = LstDt(i, j) Next j k = k + 1 End If Next i Set OutWs = Nothing LstDt = Empty UserForm1.Show (vbModeless)End Sub
- ベストアンサー
- Visual Basic
- 最終セルまでデータを反映させるマクロ
あるサイトからの利用コードです。 それをアレンジしようとしましたが、つまずきました。 マクロコードをご教示ください。 あるフォルダに複数のエクセルファイルがあります。 構成が同じシート(名前は同じ。仮に "各シート")を、 別ブック(仮に "まとめ")の一つのシートに纏めます。 その時、複数ファイルの D4のデータだけは "まとめ"ブックのL列に反映させたいのですが、 下記コードを使用すると、どこにどのようなコードを入れたら良いのでしょうか？ 因みに複数ファイルの8行目からコピーされ、 複数ファイルのＣからM列は まとめブックのAからK列に反映されるようになってます。 (まとめブックの1行目は見出し) Dim i As Integer Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long Set WS2 = Sheets("まとめ") strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Sheets("各シート") With WS1.Range("C7") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 11).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With _____ここで つまずく_____ With WS1.Range("D4") .Copy WS2.Range("L" & WS2.Rows.Count).End(xlUp).Offset(1) WS2.Range("L" & WS2.Rows.Count).End(xlUp).AutoFill Destination = Range("E1048576").End(xlUp).Row _____ここまで つまずく_____ WB1.Close False End If strFileName = Dir Loop End Sub エクセル2013です。 宜しくお願い致します。
- ベストアンサー
- Excel（エクセル）
- オブジェクト？？
またまた困っております inputboxで入力した日付を検索して複数選択しようとしたのですが unionの使い方がよくわかりません(・・;) どこが間違っているのかもしくは何が足りないのか教えてください<m(__)m> どうかよろしくお願いします！ Option Explicit 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 grahu As Chart Dim target As Range 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 Set target = Union(target, "D" & i) Else If InStr(msg, .Range("A" & i)) = 0 Then msg = msg & .Range("A" & i) & vbCrLf End If End If Next i target.Select End With If msg <> "" Then MsgBox msg End If MsgBox "グラフベースを作成しました" End Sub Set target = Union(target, "D" & i) ↑ここでエラーが起きて 「オブジェクトが必要です」と言われました どうすればよいのでしょうか？
- ベストアンサー
- Visual Basic
- VBAでソースから全てのURLを取得したい
VBAでソースに書いてある全てのURLを取得したいのですが、現状では一部しか取得できません。 文字数制限にでも引っかかっているのでしょうか？ どうすれば全てのURLを取得できるのか・・添削して頂けると or ヒントを教えて頂けると助かります。 よろしくお願いします。 (Excel2003を使用) Sub test() Dim objIE As Object Dim objTAG As Object Dim source As String Dim url As String Dim url_start As String Dim url_end As String Dim y As Long url_end = 1 y = 1 Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = False objIE.Navigate "http://dir.yahoo.co.jp/" Do While objIE.Busy = True DoEvents Loop Application.Wait Time:=Now + TimeValue("00:00:03") source = objIE.Document.All(1).Innerhtml Do While y < 10000 url_start = InStr(url_end, source, "<a href=", vbTextCompare) If url_start = 0 Then y = 10000 Else url_end = InStr(url_start, source, ">", vbTextCompare) url = Mid(source, url_start + 9, url_end - url_start - 10) Cells(y, 1).Value = url y = y + 1 End If Loop End Sub
- ベストアンサー
- Visual Basic
- 複数のエクセルシートをまとめるマクロ
下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub
- ベストアンサー
- Excel（エクセル）
補足
どうもありがとうございます。 このサイトでデータを抜けたら不要な作業がなくなるの 頑張っています。 objStm.Write oHttp.responsebody ここで3001エラーが発生するのですが なぜエラーが発生しているのか理解できません。 よろしければ教えてもらえないでしょうか？