動作環境
Excel2016 64bitで確認
シート目次作成マクロ
シートが増えてくると目次があれば便利です。
シートの一覧とリンクを自動作成します
Sub ListSheetsName()
Dim objSheet As Object
Dim i, arow, acolumn
Cells(1, 1).Select
i = 1 'No記載用
arow = 6 '貼り付け開始行数
acolumn = 2 '貼り付け開始列
For Each objSheet In ActiveWorkbook.Sheets
'NO記載
Cells(arow, acolumn) = i
'リンク作成
ActiveSheet.Hyperlinks.Add Anchor:=Cells(arow, acolumn + 1), Address:="", SubAddress:="'" & objSheet.Name & "'!a1", TextToDisplay:=objSheet.Name
arow = arow + 1
i = i + 1
Next
End Sub
指定フォルダのファイル一覧を取得
Sub ファイル名取得()
Dim BUF As String
Dim i As Integer 'カウンタ
Dim i2 As Integer '書き込み行カウンタ
Dim mypas
mypas = Cells(1, 2)
MsgBox mypas
BUF = Dir(mypas & "\*", vbDirectory)
i = 1
i2 = 4
Do While BUF <> ""
If BUF <> "." And BUF <> ".." Then
Worksheets("Sheet1").Cells(i2, 1) = i
Worksheets("Sheet1").Cells(i2, 2) = BUF
i = i + 1
i2 = i2 + 1
End If
BUF = Dir()
Loop
End Sub
指定フォルダ配下のファイル一覧を再帰的に取得する
ファイルのリストを作成するときに
Sub 実行()
Call setFileList(Cells(3, 2)) 'フォルダパスを入力するセル
End Sub
Sub setFileList(searchPath)
Dim startCell As Range
Dim maxRow As Long
Dim maxCol As Long
Set startCell = Cells(6, 2) 'このセルから出力し始める
startCell.Select
'シートをいったんクリア
maxRow = startCell.SpecialCells(xlLastCell).Row
maxCol = startCell.SpecialCells(xlLastCell).Column
Range(startCell, Cells(maxRow, maxCol)).ClearContents
Call getFileList(searchPath)
startCell.Select
End Sub
Sub getFileList(searchPath)
'Microsoft Scripting Runtime参照
Dim FSO As New FileSystemObject
Dim objFiles As File
Dim objFolders As Folder
Dim separateNum As Long
'サブフォルダ取得
For Each objFolders In FSO.GetFolder(searchPath).SubFolders
Call getFileList(objFolders.Path)
Next
'ファイル名の取得
For Each objFiles In FSO.GetFolder(searchPath).Files
separateNum = InStrRev(objFiles.Path, "\")
'セルにパスとファイル名を書き込む
'パス
ActiveCell.Value = Left(objFiles.Path, separateNum - 1)
'ファイル名
ActiveCell.Offset(0, 1).Value = Right(objFiles.Path, Len(objFiles.Path) - separateNum)
'更新日時
ActiveCell.Offset(0, 2).Value = FileDateTime(objFiles)
'サイズ
ActiveCell.Offset(0, 3).Value = Format((FileLen(objFiles) / 1024), "#.0")
'拡張子
ActiveCell.Offset(0, 4).Value = FSO.GetExtensionName(objFiles.Path)
'次のセルを選択する
ActiveCell.Offset(1, 0).Select
End Sub
ほか
BIOS情報
Sub BIOS取得()
Dim BiosSet As SWbemObjectSet
Dim Bios As SWbemObject
Dim Locator As SWbemLocator
Dim Service As SWbemServices
Dim MesStr As String
Set Locator = New WbemScripting.SWbemLocator
Set Service = Locator.ConnectServer
Set BiosSet = Service.ExecQuery("Select * From Win32_BIOS")
For Each Bios In BiosSet
MesStr = "BIOSの種類：" + Bios.Description + vbCrLf + _
"BIOSの製造元：" + Bios.Manufacturer + vbCrLf + _
"BIOSのシリアルナンバー：" + Bios.SerialNumber + vbCrLf + _
"BIOSのバージョン：" + Bios.SMBIOSBIOSVersion
Next
'"機種：" + Bios.Model + vbCrLf + _
MsgBox "BIOSの色々な情報です。" + _
vbCrLf + MesStr + vbCrLf + "です。"
Set BiosSet = Nothing
Set Bios = Nothing
Set Locator = Nothing
Set Service = Nothing
End Sub
マザーボード情報取得
Sub マザーボード取得()
Dim BaseSet As SWbemObjectSet
Dim Base As SWbemObject
Dim Locator As SWbemLocator
Dim Service As SWbemServices
Dim MesStr As String
Set Locator = New WbemScripting.SWbemLocator
Set Service = Locator.ConnectServer
Set BaseSet = Service.ExecQuery("Select * From Win32_BaseBoard")
For Each Base In BaseSet
MesStr = "マザーボードの製造元：" + Base.Manufacturer + vbCrLf + _
"マザーボードの製品名：" + Base.Product + vbCrLf + _
"マザーボードのバージョン：" + Base.Version
Next
MsgBox "マザーボードの色々な情報です。" + _
vbCrLf + MesStr + vbCrLf + "です。"
Set BaseSet = Nothing
Set Base = Nothing
Set Locator = Nothing
Set Service = Nothing
End Sub
インターネットからファイルをダウンロードする
特定サイトからファイルをダウンロードしたい場合に
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
Private Declare PtrSafe Function DeleteUrlCacheEntry _
Lib "wininet" Alias "DeleteUrlCacheEntryA" _
(ByVal lpszUrlName As String) As Long
Private Declare PtrSafe Sub Sleep _
Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub Main()
' 概 要：インターネットからファイルをダウンロードする
Dim strUrl As String 'ダウンロード対象のURL
Dim strFilePath As String '保存先パス
'ダウンロード先URL 以下は構成調査のCSVの例
strUrl = "https://www.e-stat.go.jp/stat-search/file-download?statInfId=000031524010&fileKind=1"
' ダウンロードしたファイルの保存先
strFilePath = ThisWorkbook.Path & "\SaveFile.csv"
If Download(strUrl, strFilePath) Then
MsgBox "ダウンロードが完了しました", vbInformation, "ダウンロードの完了"
Else
MsgBox "ダウンロードに失敗しました", vbCritical, "ダウンロードの失敗"
End If
End Sub
' ----------------------------------------------------------
' 引 数：lngWaitMs 待機するミリ秒
' 戻り値：True：成功 False：失敗
' ----------------------------------------------------------
Private Function Download(ByVal strUrl As String, _
ByVal strFilePath As String, _
Optional ByVal lngWaitMs As Long = 5000) As Boolean
Dim lngResult As Long
' キャッシュのクリア
DeleteUrlCacheEntry (strUrl)
' ファイルのダウンロード
lngResult = URLDownloadToFile(0, strUrl, strFilePath, 0, 0)
' ダウンロードできたかどうかを戻り値へ
Download = (lngResult = 0)
' 待機
Sleep (lngWaitMs)
End Function
##履歴
2021/10/28 作成
2021/11/11 ダウンロードマクロを追加、その他微修正