DuKiccoの雑記

My Life Is Myself

【Web上のファイルや画像をダウンロード、URLDownloadToFile】【VBA】

Web上のファイルをダウンロードする際に

・ファイルのURLに法則性があり機械的に決まっている。
・ダウンロードしたファイル名を自分で決めて保存したい。

といったケースに大変便利です。

例えばYahooFinanceのトヨタ自動車証券コード7203)の日足チャートは以下のようにURLが決まっています。
以下の日足チャートをダウンロードしてみます。

"http://chart.yahoo.co.jp/?code=7203.T&tm=1y&type=c&log=off&size=m&over=m65,m130,s&add=vm,ss&comp="


f:id:DuKicco:20160606074254j:plain


ちなみに証券コード(7203)部分を書き換えると他社の日足チャートになります。

'宣言部に以下の記述が必要

Private Declare PtrSafe 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 testURLD()
'指定した証券コードの日足チャートを本ファイルと同じフォルダに証券コード名で保存する。

Dim SaveFN As String, DFURL As String, ReturnValue As Long, SCode As Long

    SCode = 7203 '証券コード。7203→トヨタ自動車
    SaveFN = ThisWorkbook.Path & "\" & SCode & ".jpg" '画像ファイルの保存先とファイル名を設定
    DFURL = "http://chart.yahoo.co.jp/?code=" & SCode & ".T&tm=1y&type=c&log=off&size=m&over=m65,m130,s&add=vm,ss&comp=" 'ダウンロードしたいファイルのURLを設定

    ReturnValue = URLDownloadToFile(0, DFURL, SaveFN, 0, 0) '実行部分
    
        
    If ReturnValue = 0 Then 'ダウンロードに成功すると「ReturnValue =0」となる。ただの確認
        Debug.Print "ダウンロード成功"
        Else
        Debug.Print "ダウンロード失敗"
    End If
    
End Sub

エクセルでバーコードを利用する-1

備品の管理をエクセルで行っているような場合に、エクセルで管理番号をバーコード印刷できると便利です。

 

方法は大まかに2つあります。「1は簡便、2はバーコードの種類が多く細かな設定が可能」という利点があげられます。今回は1について書きます。

 

1.バーコードフォントを利用する。

2.Barcodecontrolを利用する。

 

 

バーコードフォントの利用手順

 

フォントをダウンロード

フォントのインストール

という手順になります。インストールすると明朝体などの並びにバーコードのフォントが選べるようになり、セルのフォントをバーコードフォントに指定するだけで、セルの文字がバーコードで表示されます。

以下のサイトで3種類のフォントがダウンロードできます。

www.technical.jp

選択したフォントによっては前後に特定の文字を付ける必要があります。

 

参考

フォントのインストール方法(Windows 7 の場合)

 *アドミン権限が必要でした。

 

www.keyence.co.jp

【必携Function-1】【エクセル2013,VBA】

新しくエクセルのアプリケーションを作る際には、便利なFunctionの一群をまずはごっそり移すところからはじめます。

以下、必携のファンクションを紹介します。

1.GetDeskTopPath
デスクトップのパスを取得するファンクション。例えば↓のような使い方をします。
デスクトップのパスをデフォルトの保存場所などにしておくと、不特定のPCでも動作するファイルになります。

Thisworkbook.pathも同じような目的で使用します。また「("Desktop")」を変更すればマイドキュメント等のパスの取得も可能です。

2.GetUserName,GetComputerName
user nameやコンピュターnameを取得するファンクション。例えば↓のような使い方をします。
社用PCなどuser nameと利用者情報の対応表が存在する場合、このファンクションを利用して利用者情報の自動入力補助ができるようになります。

3.SelectFold,SelectFile
ダイヤログボックスからフォルダやファイルを指定(=パスを取得)できます。
動的なアプリケーションに必須です。

動的にしておくと、様々なデータやファイルで検証しやすいのでテストの際などにも便利です。

Sub 動作確認()

MsgBox "Functionの動作確認 "
MsgBox GetDeskTopPath
MsgBox GetUserName
MsgBox GetComputerName
MsgBox SelectFold
MsgBox SelectFile

End Sub

Function GetDeskTopPath()
    'デスクトップパス取得
    Dim MyWSH  As Object
    Set MyWSH = CreateObject("WScript.Shell")
    
    GetDeskTopPath = MyWSH.SpecialFolders("Desktop")
    
    Set MyWSH = Nothing
End Function

Function GetUserName()
    'ユーザーネーム取得
    Dim WshNetworkObject As Object
    Set WshNetworkObject = CreateObject("WScript.Network")
      
    GetUserName = WshNetworkObject.UserName

    Set WshNetworkObject = Nothing
    
End Function

Function GetComputerName()
    'コンピューターネーム取得
    Dim WshNetworkObject As Object
    Set WshNetworkObject = CreateObject("WScript.Network")
      
    GetComputerName = WshNetworkObject.ComputerName

    Set WshNetworkObject = Nothing
    
End Function

Function SelectFold() As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダー選択"
        If .Show = -1 Then
            SelectFold = .SelectedItems(1)
        Else                'キャンセルボタンがクリックされた
            SelectFold = "CANCEL"
        End If
End With

End Function

Function SelectFile() As String

With Application.FileDialog(msoFileDialogFilePicker)
.Title = "ファイル選択"
        If .Show = -1 Then
            SelectFile = .SelectedItems(1)
        Else                'キャンセルボタンがクリックされた
            SelectFile = "CANCEL"
        End If
End With

End Function

【2つのシートの内容を比較】【エクセル2013,VBA】

複数人で同一ファイルに書き込みをするような作業の際に、作業前のシートと作業後のシートを比較し、どこが修正されたかを確認したくなる場合があります。中には適当なひとやエクセルが苦手なひともいたりするため、気がつかずに違うセルの内容を消したり上書きしたり等のミスが生じることがあります。

 

比較の対象は「値と数式」です。数式は見た目にはわからなくとも、セルの削除などでおかしなことになるときがあります。書式も比較できるようにしたかったのですが、長くなるので断念しました。

 

内容

Step0.比較したい2つのシートは同一ブック内にあることが前提。

Step1.比較したい1枚目のシートの比較したい範囲を指定する。

Step2.比較したい2枚目のシートの名前を入力する。

Step3,4.比較作業が行われる。結果は追加されたシートに出力される。(青塗りだと変化なし。赤塗りだと値または数式が異なる。表示されている値は比較シート1の値。)

 

f:id:DuKicco:20150531085136j:plain

以下コード

=========================================================

Sub シート比較()

Dim SN1 As String, SN2 As String, SN As String, buf As Range, TCell As Range

'Step1:比較したいシート(1枚目)の比較したい範囲を選択
Set buf = Application.InputBox(prompt:="比較したいシート(1枚目)の範囲を選択してください)", Type:=8)
SN1 = buf.Parent.Name

 

'Step2:比較したいシート(2枚目)の名前を入力。デフォルト値は2枚目のシート
SN2 = InputBox("比較したいシート(2枚目)の名前を入力", "", Sheets(2).Name)

 

'Step3:比結果の記入用シートの追加
Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
SN = ActiveSheet.Name


'Step4:指定した各セル内容を比較していき、結果シートに記入する。
For Each TCell In buf
'結果シートの対応するセルに比較シート1の数式なければ値を記入していく(書式は関係なし)
Sheets(SN).Range(TCell.Address).Formula = TCell.Formula
'比較シート1と2の数式なければ値を比較し異なる場合には結果シートの対応するセルを赤塗りにしていく。同一であれば青塗り。
If TCell.Formula <> Sheets(SN2).Range(TCell.Address).Formula Then
Sheets(SN).Range(TCell.Address).Interior.Color = 255
Else
Sheets(SN).Range(TCell.Address).Interior.Color = 15773696
End If

Next

End Sub

【複数ブック、アンケート、集計】【エクセル2013,VBA】

アンケートをエクセルで作成し、とりまとめ集計するためののコード。

なるべく汎用的に利用できるように、集計範囲をダイアログボックスで指定できるようにしています。

 

f:id:DuKicco:20150530094924j:plain

前提としては

・集計するブックの構成(回答の場所)は全て同じアドレスのセル

・アンケート結果は各ブックの1枚目のシートに記載する

・アンケートのブックは複数指定可

 

==================================

Sub アンケート集計()

Dim i As Long, j As Long, k As Long, GyoN As Long, tst As String, CellA As String, SN As String
Dim buf As Range, TCell As Range, arr1() As String


Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
SN = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name


'Step1:集計するセルの指定を行う
With Application.FileDialog(msoFileDialogOpen)
.Title = "まずは集計するセルを指定します。" & Chr(13) & "どれでもよいので集計したいファイルをひとつ開いてください。"
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Show

Workbooks.Open Filename:=.SelectedItems(1)
tst = ActiveWorkbook.Name
Set buf = Application.InputBox(prompt:="集計したいセルを選択してください(+ctrで複数選択可)", Type:=8)

ReDim arr1(1 To buf.Cells.Count) As String

i = 1
'セルのアドレスを配列に格納と同時にアドレスを記録
For Each TCell In buf
arr1(i) = TCell.Address
ThisWorkbook.Sheets(SN).Cells(1, i) = arr1(i)

i = i + 1
Next


Workbooks(tst).Close SaveChanges:=False

End With


'Step2:集計
GyoN = 2
With Application.FileDialog(msoFileDialogOpen)
.Title = "集計したいファイルを選択してください(+ctrで複数選択可)"

'複数指定可

.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = True
.Show


'順番にファイルを開き、step1で指定したセルをシートに書き出していく
For i = 1 To .SelectedItems.Count

Workbooks.Open Filename:=.SelectedItems(i)
tst = ActiveWorkbook.Name

For k = 1 To UBound(arr1)
'シートは一枚目のみ利用する。2枚目以降は無視される。

’追加したシートに書き出し
ThisWorkbook.Sheets(SN).Cells(GyoN, k) = Workbooks(tst).Sheets(1).Range(arr1(k))

Next

GyoN = GyoN + 1
Workbooks(tst).Close SaveChanges:=False
Next

End With

End Sub

【複数のブックをひとつのブックにまとめる】【エクセル2013,VBA】

複数のブックをまとめるコード。例えばエクセルで作成した雛形やアンケートをメールで配り記入してもらい、その回答をひとつのブックにまとめたい場合に使用する。

 

以下コード

==============================================================

Sub シート集計()
Dim i As Long, tst As String, CellA As String

'シート内の特定のセルをシート名にしたい場合はCellAにアドレスを入れる。例:各シートのRange("A1")に名前や固有のIDが入っていてそれをシート名にしたい場合「CellA="A1"」とする。
CellA = ""

With Application.FileDialog(msoFileDialogOpen)
.Title = "統合したいエクセルファイルを選択(+ctr or +shiftで複数選択)"
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = True
.Show

For i = 1 To .SelectedItems.Count

'フルパスからファイル名を取得する。
tst = Dir(.SelectedItems(i))
'選んだブックを順に開く
Workbooks.Open Filename:=.SelectedItems(i)
'シートは「すべて」コピーされる。
Sheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'CellAが空欄でなければシート名を書き換える
If CellA <> "" Then
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Range(CellA)
End If

'ブックを閉じる。
Workbooks(tst).Close SaveChanges:=False

Next
End With

End Sub


Sub 特定シートの削除()
'おまけ。特定の名前のついているシートを削除する。
Dim SN As String, SC As Long
Application.DisplayAlerts = False
'↓の場合はSheetという文字が含まれるシートを削除
SN = "Sheet"
SC = Sheets.Count
For i = SC To 1 Step -1
If InStr(1, Sheets(i).Name, SN) > 0 Then
Sheets(i).Delete
End If
Next
Application.DisplayAlerts = True
End Sub


Sub シート削除All()
'Sheets(1)を除くすべてのシートを削除する。
On Error Resume Next
Dim SN As String, SC As Long
Application.DisplayAlerts = False
SC = Sheets.Count
For i = SC To 1 Step -1
Sheets(i).Delete
Next
Application.DisplayAlerts = True
End Sub

【カレンダーの休日を条件付き書式設定で網掛けにする】【エクセル2013,VBA】

チェック表や予約表をエクセルで毎月作成しプリントアウトして使用しているケース多いと思います。毎月手作業で、網掛けにしたり書式を変えたチェック表や予約表の作成を行っている人をみかけると条件付き書式設定が便利ですよと教えてあげたくなるのだけど、その説明が面倒です。加えて、一ヶ月が短い月の表示の対応だとか、会社の休日の対応だとか当然出てくる要望に対処していくと、どんどん説明が面倒になります。なので、しばらくはこちらでファイルをもらって条件付き書式設定してあげるのですが、数が多くなってくると縦・横・分割様々なタイプの表がくるし、時々修正などの要望も入るので、やはり対応が面倒なので自動化をこころみてみました。

 

ダイアログボックスからの入力だけで、もらったカレンダーの書式設定が簡単にできるコードを書いてみました。

 

設定の流れ

1.年をリストボックスで表示するセルを選択(初期値A1)

Office TANAKA - Excel VBA Tips[実は奥が深いInputBox]

(inputboxで範囲を指定)

 

2.月をリストボックスで表示するセルを選択(初期値B1)

別のシートでも可(複数シートの表示月を連動させたい場合はどこか一箇所をしていすればよい)

 

3.開始日を入力(初期値1)

16日スタートなども可。表が分割されているようなケースに使う。

 

4.休日リスト(土日以外の休日。祝日含む)を別シートに用意し、その範囲を指定する(なくても可)。

祝日リストはネットにころがっているので入手し会社の休日があればそれに付け加える。

 

5.条件付き書式設定したい範囲を指定する。

 

6.表の方向を指定する(縦or横)

選択した方向に応じ、1行or1列目に日付を表示する数式がセルに入力される。

 

最初のセルの数式は「=Date(年,月,開始日)」のシリアル値とし、

Range(XXX).NumberFormatLocal = "d""(""aaa"")"とすることで日にちと曜日のみを表示する。

DATE関数の使い方 初心者のエクセル(Excel)学習・入門

6.5 文字の表示形式に関する書式設定 - Excel VBA Tips

 

1行or1列目の数式を以下のように設定

「=IF(INDIRECT(""R[-1]C"",FALSE)="""","""",IF(DAY(INDIRECT(""R[-1]C"",FALSE)+1)=1,"""",INDIRECT(""R[-1]C"",FALSE)+1))」

相対位置を参照する~ExcelでのINDIRECTのすすめ~:システム開発メモ:So-netブログ

 

選択された範囲に条件付き書式が設定される。

土曜日→青の網掛け

日曜日、休日→赤の網掛

テーマカラーでセルの網かけに色を付ける - PatternThemeColorとPatternTintAndShadeプロパティ - Excel VBA Tips

Excel(エクセル)基本講座:条件付き書式で土日に色を付ける

 

f:id:DuKicco:20150412114626j:plain

参考

エクセルExcel大事典 VBAマクロ 日付関数 DateAdd DateDiff DatePart DateSerial Timer

 

=============================================================

Sub 書式設定()

On Error GoTo ELH

Dim YCell As String, Mcell As String, YList As String, buf As Range, StartC As String, StartR As Long, StartD As Long, i As Long, RCType As String, tst As String, Arr(1 To 4) As Variant

'初期設定値(繰り返し同じ範囲を指定するなら、ここを書き換えておく)
Arr(1) = "$A$1" '年を表示するセル
Arr(2) = "$B$1" '月を表示するセル
Arr(3) = "" '休日リスト範囲例:Sheet1!$A1:$A$100
Arr(4) = "$B$5:$F$34" '条件付書式を設定する範囲

Set buf = Application.InputBox(PROMPT:="年を表示するセルを選択", Type:=8, Default:=Arr(1)) '年を表示するセルを選択
YCell = buf.Worksheet.Name & "!" & buf.Address

buf(1).Select
buf(1) = Year(Date) '初期値=今年

With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Year(Date) & "," & Year(Date) + 1 & "," & Year(Date) + 2 '3年分
.IgnoreBlank = True
.InCellDropdown = True
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With


Set buf = Application.InputBox(PROMPT:="月を表示するセルを選択", Type:=8, Default:=Arr(2)) '月を表示するセルを選択

Mcell = buf.Worksheet.Name & "!" & buf.Address

buf(1).Select
buf(1) = Month(Date) '初期値=今月

With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="1,2,3,4,5,6,7,8,9,10,11,12"
.IgnoreBlank = True
.InCellDropdown = True
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With

StartD = InputBox("カレンダーの開始日を入力", "入力", 1) '開始日を入力


If MsgBox("休日リストを使用しますか?", vbYesNo) = vbYes Then '休日リストの設定。リストはシリアル値で。休日を追加する予定なら広めに指定しておけばよい

Set buf = Application.InputBox(PROMPT:="休日リストが表示されている範囲を選択", Type:=8, Default:=Arr(3))
YList = buf.Worksheet.Name & "!" & buf.Address

Else
YList = ""

End If

Set buf = Application.InputBox(PROMPT:="条件付書式を設定したい範囲を選択", Type:=8, Default:=Arr(4)) '条件付書式を設定したい範囲を選択
Sheets(buf.Worksheet.Name).Select
buf.Select
StartC = Mid(buf(1).Address, 2, InStr(2, buf(1).Address, "$") - 2)

StartR = buf(1).Row
'最初のセルに年と月と開始日からシリアル値を返す数式を入力。表示は日付と曜日のみ。
buf(1) = "=Date(" & YCell & "," & Mcell & "," & StartD & ")"
buf(1).NumberFormatLocal = "d""(""aaa"")"""

RCType = MsgBox("日付の記載方向。" & Chr(13) & "縦方向なら→はい。横方向なら→いいえ。", vbYesNo)

If RCType = 7 Then '横の場合
tst1 = ""
tst2 = "$"
RangeST = tst1 & StartC & tst2 & StartR
'1行目に日付の表示。シリアル値。表示は日付と曜日のみ。
Range(Cells(buf(1).Row, buf(1).Column + 1), Cells(buf(1).Row, buf(buf.Count).Column)) = "=IF(INDIRECT(""RC[-1]"",FALSE)="""","""",IF(DAY(INDIRECT(""RC[-1]"",FALSE)+1)=1,"""",INDIRECT(""RC[-1]"",FALSE)+1))"
Range(Cells(buf(1).Row, buf(1).Column + 1), Cells(buf(1).Row, buf(buf.Count).Column)).NumberFormatLocal = "d""(""aaa"")"""
Else '縦の場合
tst1 = "$"
tst2 = ""
RangeST = tst1 & StartC & tst2 & StartR
'1列目に日付の表示。シリアル値。表示は日付と曜日のみ。
Range(Cells(buf(1).Row + 1, buf(1).Column), Cells(buf(buf.Count).Row, buf(1).Column)) = "=IF(INDIRECT(""R[-1]C"",FALSE)="""","""",IF(DAY(INDIRECT(""R[-1]C"",FALSE)+1)=1,"""",INDIRECT(""R[-1]C"",FALSE)+1))"
Range(Cells(buf(1).Row + 1, buf(1).Column), Cells(buf(buf.Count).Row, buf(1).Column)).NumberFormatLocal = "d""(""aaa"")"""
End If


tst = "=Weekday(" & RangeST & ")=1"
Call SelectionFormat1(255, tst) '日曜日の条件付書式設定。

tst = "=Weekday(" & RangeST & ")=7"
Call SelectionFormat1(15773696, tst) '土曜日の条件付書式設定


If YList <> "" Then '休日リストを使用する場合
tst = "=COUNTIF(" & YList & "," & RangeST & ")>0" 'countifで休日かどうか判断
Call SelectionFormat1(255, tst) '休日の条件付書式設定
End If

Exit Sub

ELH:

MsgBox "終了です。"

End Sub


Sub SelectionFormat1(ColorNo As Long, tst As String)

'条件付書式設定。網掛けの色(ColorNo)と条件式(tst)を引数としている。

Selection.FormatConditions.Add Type:=xlExpression, Formula1:=tst
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

With Selection.FormatConditions(1).Interior

.Pattern = xlGray8
.PatternColor = ColorNo
.ColorIndex = xlAutomatic
.TintAndShade = 0
.PatternTintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = False

End Sub