「VBA(Excel)」カテゴリーアーカイブ

Excel2016の初期フォントを変更

投稿日時: 投稿者:

エクセルの初期フォントを変更したい場合、変更したBookを
下記の名前(テンプレート形式)で、下記の2つのフォルダにコピーする。

Book.xltx
C:\Users\XXXXX\AppData\Roaming\Microsoft\Excel\XLSTART
C:\Users\XXXXX\Documents\Office のカスタム テンプレート

上のフォルダの違いは、Excel起動時にテンプレート選択を有効にしているか否か。

メモ:
游ゴシック
游ゴシック Light

VBA:MS-Access(DAO)テンプレート

投稿日時: 投稿者:

ExcelからMS-Accessのデータを簡易取り出し。

1
2
3
4
5
6
7
8
9
10
11
12
dbPath = "xxx.accdb"
Set dbe = CreateObject("DAO.DBEngine.120")
Set Db = dbe.Workspaces(0).OpenDatabase(dbPath, False)
 
Sql = "select x from xxxx where xx ="x"
Set dbRes = Db.OpenRecordset(Sql)
wkCMT = dbRes("x").Value
 
dbRes.Close
Db.Close
Set Db = Nothing
Set dbe = Nothing

 

VBA: WEBページ(HTML)をローカルに保存

投稿日時: 投稿者:

指定のURLから生成されるHTMLをファイル化して、ローカルに保存する。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryW" ( _
    ByVal lpszUrlName As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileW" ( _
    ByVal pCaller As Long, _
    ByVal szURL As Long, _
    ByVal szFileName As Long, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long
  
Public Sub test_download()
    If HTML_Download("http://xxxx", "C:\temp\test.html") <> 0 Then
        MsgBox "Fail!"
    Else
        MsgBox "Done!"
    End If
End Sub
  
Function HTML_Download(ByVal HTML_URL As String, ByVal SavePath As String) As Long
    DeleteUrlCacheEntry StrPtr(HTML_URL)
    HTML_Download = URLDownloadToFile(0, StrPtr(HTML_URL), StrPtr(SavePath), 0, 0)
End Function

VBA:HTML内から値の取り出し

投稿日時: 投稿者:

HTMLファイル内にあるテーブル<table>内の値を取り出す。
今まではINSTR関数で地道に処理していたが、もっとスマートな方法を準備した。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub html_TD_value()
    Dim objXML As New MSHTML.HTMLDocument
    Dim htmlDoc As New MSHTML.HTMLDocument
    Dim htmlDoc2 As Object
    Dim htmlDoc3 As Object
    Dim htmlDoc4 As Object
 
    ' 事前に出力されたHTMLファイルを取り扱う
    Set htmlDoc = objXML.createDocumentFromUrl("file:///C:/temp/test.html", vbNullString)
 
    'wait処理が面倒だから0.5秒待つことにする(ローカルファイルアクセスのため高速なはず)
    Application.Wait [Now() + "0:00:00.5"]
 
   ' id="xxxx"まで飛ぶ
    Set htmlDoc2 = htmlDoc.getElementById("xxxx")
   '1行目(TR)は飛ばして2行目から処理
    For i = 1 To htmlDoc2.getElementsByTagName("tr").Length - 1
 
        '
<TR>まで飛ぶ
        Set htmlDoc3 = htmlDoc2.getElementsByTagName("tr")(i)
        For j = 0 To htmlDoc3.getElementsByTagName("td").Length - 1
 
            '
<TR>内の
<TD>まで飛ぶ
            Set htmlDoc4 = htmlDoc3.getElementsByTagName("td")(j)
            '
<TD>の値をゲット
            Debug.Print i, j, htmlDoc4.innerText
 
        Next
    Next
End Sub

VBA:文字列検索&色付け

投稿日時: 投稿者:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub moji_color()
    Dim area As Range, onesell As Range, i As Long
    Dim moji As Long, keyw As String
    '対象範囲と検索文字列
    Set area = Application.InputBox(Prompt:="検索対象をセル範囲してください。", Type:=8)
    keyw = Application.InputBox(Prompt:="色付けるキーワードは?", Type:=2)
    'セル範囲ループ
    For Each onesell In area
        moji = 1
        '1セル毎に文字チェック
        Do While moji <= Len(onesell)
            i = InStr(moji, UCase(onesell), UCase(keyw), 1)
            If i = 0 Then Exit Do
            '見つかったら赤くする
            onesell.Characters(i, Len(keyw)).Font.Color = vbRed
            moji = moji + i
        Loop
    Next
End Sub

VBA: HTML操作

投稿日時: 投稿者:

久し振りにVBAでIEを制御したのでメモ。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
'定番
Dim ObjIE As Object
Dim wkTEXT As String
Set ObjIE = CreateObject("InternetExplorer.application")
ObjIE.Visible = True
ObjIE.Navigate "http://xxxxxxxx"
 
'WAIT
Do While ObjIE.Busy Or ObjIE.ReadyState &lt; READYSTATE_COMPLETE
    Debug.Print ObjIE.Busy &amp; ":" &amp; ObjIE.ReadyState
    DoEvents
Loop
 
'INPUT FORM &amp; SUBMIT　ボタンなどがID化されてること
ObjIE.Document.body.all("yyyyyy").Value = wkTAG
ObjIE.Document.body.all("zzzzz").submit
 
'Other  qqqqqqqqqq配下のHTMLを取り出し
wkTEXT = ObjIE.Document.body.all("qqqqqqqqqq").Children(0).outerHTML
'Other  ページのタイトル
wkTEXT = ObjIE.Document.Title
'Other  BODY内のテキスト
wkTEXT = ObjIE.Document.Body.innerText

 

VBA:シェイプへの画像挿入、共通イベントの作成

投稿日時: 投稿者:

友人に頼まれて、かつJavaScriptとjQueryの勉強も兼ねてツールを作ってみた。
といってもいきなりは難しいから、Excel版でプロタイプを作ってみた。
風呂の中、電車の中でロジックを考えて、昼休みに一気に作り込み。
※電車の中でシェイプの使い方は事前勉強
1時間で出来たことは、我ながら。。。
でも、本命のWEB版は、、、挫折しそう。

Excel版の特徴:

  • 画像ファイルを順番に読み込んでシェイプに入れ込み、名前を振る
  • 各シェイプクリック時のイベントを作成、でもシェイプ毎はしんどいので1つの関数に統一
    ※機能というか動きは一緒なので
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
'シェイプへの画像入れ込み、共通イベントの作成
Sub read_card_make_shape()
    Dim myFileName As String
    Dim myShape As Shape, item_name As String
    Dim D As String: D = Chr(34)
    Dim Y As Integer
 
    '事前準備した画像フォルダへのパス
    myFileName = "c:\temp\game.img\"
    Y = 2: Do While Sheets("data").Cells(Y, 1).Value <> "": Y = Y + 1: Loop: Y = Y - 1
 
    For i = 2 To Y
        '画像ファイルをシェイプにセット
        Set myShape = ActiveSheet.Shapes.AddPicture( _
              fileName:=myFileName & Sheets("data").Cells(i, 1).Value & ".jpg", _
              LinkToFile:=False, _
              SaveWithDocument:=True, _
              Left:=((i - 2) Mod 10) * 62, _
              Top:=((i - 2) \ 10) * 92 + 250, _
              Width:=60, _
              Height:=90)
        'シェイプに命名、クリック時のイベントにシェイプ名を渡す
        item_name = Sheets("data").Cells(i, 1).Value
        myShape.Name = item_name
        ActiveSheet.Shapes(item_name).OnAction = "'card_click" & D & item_name & D & "'"
    Next
 
End Sub
 
Sub card_click(KEY As String)
    'クリックしたシェイプの名前をExcelセルへセット(あとはVlookup頼み)
    Dim YY As Integer
    YY = 3: Do While Sheets("main").Cells(YY, 1).Value <> "": YY = YY + 1: Loop
    If YY > 14 Then Exit Sub
    Sheets("main").Cells(YY, 1).Value = KEY
End Sub
 
Sub delete_line()
    '削除時は名称を消せば後の情報も自動で消える(Vlookup頼み)
    Dim YY As Integer
    YY = 2: Do While Sheets("main").Cells(YY, 1).Value <> "": YY = YY + 1: Loop
    Debug.Print YY
    If YY < 4 Then Exit Sub
    Sheets("main").Cells(YY - 1, 1).Value = ""
End Sub

VBA : WEB(http)先からファイル一括ダウンロード

投稿日時: 投稿者:

あるネットワーク上のファイル(今回はZIP)を一括ダウンロードする
前提:

  • 対象のファイルは同一URL配下に保管されている
  • 対象のファイルは複数ある
  • ダウンロード先(格納先)は固定で決まっている
  • 結果レポートも出力する

手順:

  • ソースに下記の修正を加える
  • コピー元のURLを指定(末尾は/で終わること)
  • コピー先のフォルダを指定(末尾は\で終わること)

下記説明:

  • 対象のファイル名リストを”_copy_list.txt”に格納し、そのファイルを”c:\temp\download\”に格納
  • 実行結果は、同フォルダ内に”_report.txt”として作成される(各行の1文字目が0なら成功)
  • 上記ファイル群が格納されているURLを準備”http://~~~~~~/~~~~~/”
  • あとは実行するだけ
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
'URLDownloadToFile API.
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
    szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
Sub batch()
 
    Dim strFNAME As String, strSRC_FILE As String
    Dim strRET As Variant
    strFNAME = "c:\temp\download\"
     
    Open strFNAME & "_copy_list.txt" For Input As #1
    Open strFNAME & "_report.txt" For Output As #2
     
    Do While Not EOF(1)
        Line Input #1, strSRC_FILE
         
        strRET = download(strSRC_FILE, strFNAME & strSRC_FILE)
        Print #2, strRET & vbTab; strSRC_FILE
        Debug.Print strSRC_FILE
        DoEvents
    Loop
     
    Close
    MsgBox "done!"
     
End Sub
 
'strURL:ダウンロード元URL(ファイル名のみ)
'strFNAME:格納先フルパス+ファイル名
Function download(strURL As String, strFNAME As String) As Variant
    Dim base_url As String
    base_url = "http://~~~~~~/~~~~~/" & strURL
    download = URLDownloadToFile(0, base_url, strFNAME, 0, 0)
 
End Function

ExcelグラフをGIF形式で保管

投稿日時: 投稿者:

マクロでExcelグラフをGIF形式でファイル保存する。

1
2
3
4
5
6
'グラフタイトルのセット(おまけ)
ActiveSheet.ChartObjects("グラフ 1").Activate
ActiveChart.ChartTitle.Select
ActiveChart.ChartTitle.Text = "title"
'グラフを選択している状態でGIFT形式でエクスポート
myRess = ActiveChart.Export("c:\temp\test.GIF", "GIF", False)

セルWクリックからIE開く

投稿日時: 投稿者:
返信
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'WクリックしたセルのX座標チェック＆値が入っているか
    If ActiveCell.Column <> 2 Or ActiveCell.Value = "" Then
        Cancel = True
        Exit Sub
    End If
 
    Dim ObjIE As Object
    Dim ObjShell As Object
    Dim ObjWindow As Object
  
    Set ObjShell = CreateObject("Shell.Application")
    '全shellをチェック
    For Each ObjWindow In ObjShell.Windows
        'IEならば
        If TypeName(ObjWindow.Document) = "HTMLDocument" Then
            Set ObjIE = ObjWindow
            'IEにURLセット＆引数
            ObjIE.Navigate ("http:ｘｘｘｘｘｘｘｘｘｘｘ=" & ActiveCell.Value)
            ObjIE.Visible = True
            Exit For
        End If
    Next
    Cancel = True
End Sub