Excel2016の初期フォントを変更

投稿日時: 2019年6月14日投稿者: admin

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

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

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

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

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

投稿日時: 2017年9月1日投稿者: admin

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

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)をローカルに保存

投稿日時: 2017年2月16日投稿者: admin

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

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内から値の取り出し

投稿日時: 2017年2月16日投稿者: admin

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


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:文字列検索&色付け

投稿日時: 2016年6月3日投稿者: admin

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操作

投稿日時: 2015年11月24日投稿者: admin

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

	'定番
	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:シェイプへの画像挿入、共通イベントの作成

投稿日時: 2015年7月3日投稿者: admin

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

Excel版の特徴:

画像ファイルを順番に読み込んでシェイプに入れ込み、名前を振る
各シェイプクリック時のイベントを作成、でもシェイプ毎はしんどいので1つの関数に統一
※機能というか動きは一緒なので

'シェイプへの画像入れ込み、共通イベントの作成
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)先からファイル一括ダウンロード

投稿日時: 2014年11月13日投稿者: admin

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

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

手順:

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

下記説明:

対象のファイル名リストを”_copy_list.txt”に格納し、そのファイルを”c:\temp\download\”に格納
実行結果は、同フォルダ内に”_report.txt”として作成される(各行の1文字目が0なら成功)
上記ファイル群が格納されているURLを準備”http://~~~~~~/~~~~~/”
あとは実行するだけ

'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形式で保管

投稿日時: 2014年9月18日投稿者: admin

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

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

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

投稿日時: 2013年10月1日投稿者: admin

返信

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

Myプログラム保管庫

仕事＆プライベートで使ったプログラムロジックの保管庫

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