ねらい：VBAで「システム情報」を素早く集め、トラブル切り分けを速くする
システム情報取得は、Excelの不具合や速度低下の原因を見極める最短ルートです。OS・Excel/Officeのビット数・バージョン、CPU・メモリ・ディスクの空き、ネットワーク、ユーザー/マシン名などを一括で取得・記録できるテンプレを用意します。初心者でも貼って動かせる形で、WMI（Win32_XXX）、環境変数、Win32 API、Excel内蔵プロパティを組み合わせます。
重要ポイントの深掘り
「どの環境で動いているか」をひと目で分かる台帳を作ることが目的です。Excelのビット数・バージョン差、OSのエディション、メモリ不足やディスク空き不足は、症状の原因に直結します。VBAは配列I/Oで一気に書き出し、外部参照なし（Late Binding）で動くようにすると配布が楽です。
取得の基盤：環境・Excel情報・OSベーシックを一気に取る
Excel/Officeのビット数・バージョン・言語
' ModExcelInfo.bas
Option Explicit
Public Function ExcelBitness() As String
#If Win64 Then
ExcelBitness = "64-bit"
#Else
ExcelBitness = "32-bit"
#End If
End Function
Public Function ExcelVersionText() As String
ExcelVersionText = Application.Version & " (" & Application.Build & ")"
End Function
Public Function OfficeLanguage() As String
OfficeLanguage = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
End Function
Public Function IsCalculationManual() As Boolean
IsCalculationManual = (Application.Calculation = xlCalculationManual)
End Function
OS・ユーザー・マシン・CPU時間などの基本情報
' ModEnvInfo.bas
Option Explicit
Public Function OsVersionText() As String
OsVersionText = CreateObject("WScript.Shell").RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductName") _
& " " & CreateObject("WScript.Shell").RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ReleaseId")
End Function
Public Function MachineName() As String
MachineName = Environ$("COMPUTERNAME")
End Function
Public Function UserName() As String
UserName = Environ$("UserName")
End Function
Public Function DotNetVersionQuick() As String
On Error Resume Next
DotNetVersionQuick = CreateObject("WScript.Shell").RegRead("HKLM\SOFTWARE\Microsoft\NET Framework Setup\NDP\v4\Full\Release")
On Error GoTo 0
End Function
Public Function UptimeMs() As Double
' 高精度：GetTickCount64 が理想だが、簡易はTimerと組み合わせ
UptimeMs = CDbl(CreateObject("WScript.Shell").Exec("cmd /c wmic os get lastbootuptime /value").StdOut.ReadAll <> "")
End Function
WMIでハードウェア・ディスク・ネットワークを取得する
CPU・物理メモリ・OSエディション・ブート時間
' ModWmiInfo.bas（Late Bindingで参照不要）
Option Explicit
Private Function WmiService() As Object
Set WmiService = GetObject("winmgmts:\\.\root\cimv2")
End Function
Public Function CpuName() As String
Dim q As Object: Set q = WmiService.ExecQuery("SELECT Name FROM Win32_Processor")
Dim it As Object
For Each it In q: CpuName = it.Name: Exit For
Next
End Function
Public Function TotalPhysicalMemoryGB() As Double
Dim q As Object: Set q = WmiService.ExecQuery("SELECT TotalVisibleMemorySize FROM Win32_OperatingSystem")
Dim it As Object
For Each it In q
TotalPhysicalMemoryGB = Round(it.TotalVisibleMemorySize / 1024# / 1024#, 2)
Exit For
Next
End Function
Public Function OsCaption() As String
Dim q As Object: Set q = WmiService.ExecQuery("SELECT Caption FROM Win32_OperatingSystem")
Dim it As Object
For Each it In q: OsCaption = it.Caption: Exit For
Next
End Function
Public Function LastBootUpTime() As String
Dim q As Object: Set q = WmiService.ExecQuery("SELECT LastBootUpTime FROM Win32_OperatingSystem")
Dim it As Object
For Each it In q
LastBootUpTime = WmiTimeToIso(it.LastBootUpTime)
Exit For
Next
End Function
Private Function WmiTimeToIso(ByVal s As String) As String
If Len(s) >= 14 Then
WmiTimeToIso = Left$(s, 4) & "-" & Mid$(s, 5, 2) & "-" & Mid$(s, 7, 2) & " " & Mid$(s, 9, 2) & ":" & Mid$(s, 11, 2) & ":" & Mid$(s, 13, 2)
End If
End Function
ドライブ空き容量・総容量（複数ドライブ対応）
Public Function DriveInfoTable() As Variant
Dim q As Object: Set q = WmiService.ExecQuery("SELECT Name, FreeSpace, Size FROM Win32_LogicalDisk WHERE DriveType=3")
Dim it As Object, rows As Long: rows = 0
For Each it In q: rows = rows + 1: Next
Dim a() As Variant: ReDim a(1 To rows + 1, 1 To 3)
a(1, 1) = "Drive": a(1, 2) = "Free(GB)": a(1, 3) = "Size(GB)"
Dim i As Long: i = 2
For Each it In q
a(i, 1) = it.Name
a(i, 2) = Round(CDbl(it.FreeSpace) / 1024# / 1024# / 1024#, 2)
a(i, 3) = Round(CDbl(it.Size) / 1024# / 1024# / 1024#, 2)
i = i + 1
Next
DriveInfoTable = a
End Function
ネットワーク（IP・DNS・接続状態の簡易）
Public Function IpAddresses() As String
Dim q As Object: Set q = WmiService.ExecQuery("SELECT IPAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled=TRUE")
Dim it As Object, res As String
For Each it In q
If Not IsNull(it.IPAddress) Then
Dim ip
For Each ip In it.IPAddress
If InStr(CStr(ip), ":") = 0 Then res = res & CStr(ip) & " "
Next
End If
Next
IpAddresses = Trim$(res)
End Function
一括収集してシートへ書くテンプレート（貼って動く）
収集→配列→一括書き込みの入口
' ModSysReport.bas
Option Explicit
Public Sub Run_SystemReport()
On Error GoTo EH
AppEnter "SystemReport"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("SysInfo")
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = "SysInfo"
End If
ws.Cells.Clear
Dim a() As Variant: ReDim a(1 To 20, 1 To 2)
Dim r As Long: r = 1
a(r, 1) = "Excel Bitness": a(r, 2) = ExcelBitness(): r = r + 1
a(r, 1) = "Excel Version": a(r, 2) = ExcelVersionText(): r = r + 1
a(r, 1) = "Office UI Language": a(r, 2) = OfficeLanguage(): r = r + 1
a(r, 1) = "Calc Manual?": a(r, 2) = IsCalculationManual(): r = r + 1
a(r, 1) = "OS Caption": a(r, 2) = OsCaption(): r = r + 1
a(r, 1) = "OS Version": a(r, 2) = OsVersionText(): r = r + 1
a(r, 1) = "Machine Name": a(r, 2) = MachineName(): r = r + 1
a(r, 1) = "User Name": a(r, 2) = UserName(): r = r + 1
a(r, 1) = ".NET v4 Release": a(r, 2) = DotNetVersionQuick(): r = r + 1
a(r, 1) = "CPU": a(r, 2) = CpuName(): r = r + 1
a(r, 1) = "Total RAM(GB)": a(r, 2) = TotalPhysicalMemoryGB(): r = r + 1
a(r, 1) = "LastBootUpTime": a(r, 2) = LastBootUpTime(): r = r + 1
a(r, 1) = "IP Addresses": a(r, 2) = IpAddresses(): r = r + 1
ws.Range("A1").Resize(r - 1, 2).Value = a
Dim drives As Variant: drives = DriveInfoTable()
ws.Range("A" & r + 1).Resize(UBound(drives, 1), UBound(drives, 2)).Value = drives
ws.Columns.AutoFit
AppLeave
MsgBox "System Report生成完了", vbInformation
Exit Sub
EH:
AppLeave
MsgBox "失敗: " & Err.Description, vbExclamation
End Sub
開始・終了の共通枠
' ModApp.bas
Option Explicit
Public Sub AppEnter(Optional ByVal status As String = "")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
If Len(status) > 0 Then Application.StatusBar = status
End Sub
Public Sub AppLeave()
Application.StatusBar = False
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
例題：遅い・落ちるの切り分けに効く「簡易ヘルスチェック」
チェックする観点と動かし方
- 空き容量が少ないドライブ（FreeSpace < 5GB）を見つける。これは保存失敗やフリーズの常連原因です。
- RAMが少ない端末（< 8GB）で巨大ファイルを扱うと固まりやすい。TotalPhysicalMemoryGBで把握します。
- Excelが32-bitで、巨大配列を扱っているか。ExcelBitnessを確認し、設計をチャンク処理に切り替える判断材料にします。
- LastBootUpTimeが古すぎる端末は、メモリリークや更新未適用の可能性。再起動の提案が合理的になります。
重要ポイントの深掘り
Late Bindingで配布トラブルを防ぐ
WMI・Shell・FileSystemObjectはCreateObject/GetObjectで動かすと参照設定不要になり、配布が楽です。COM参照のバージョン違いによる「動かない」を避けられます。
取得は「速く・まとめて・失敗に強く」
WMIは一件ずつ問い合わせるより、必要項目を一括で取り、コレクションを1回だけ走査すると速いです。ネットワークや権限で失敗する可能性もあるため、On Error Resume Nextを局所的に使い、空欄で返す設計にするとレポート生成が止まりません。
Excel依存の要素は入口で固定
計算モードや言語、ビット数の差は動作に影響します。入口で「前提」を記録し、再現テストに同じ前提を合わせると原因追跡が速くなります。
拡張テンプレ：プロセス使用率・Excelメモリ・ネット到達性
Excelプロセスのメモリ使用量（Private Bytes）を取る
' ModProcInfo.bas
Option Explicit
Public Function ExcelMemoryMB() As Double
Dim wmi As Object: Set wmi = GetObject("winmgmts:\\.\root\cimv2")
Dim pid As Long: pid = Application.Hwnd ' 実際はHwndからPID取得が必要。簡易は PowerShell 併用を推奨
' 実務は：PowerShellで (Get-Process EXCEL).PrivateMemorySize64 をCSVへ → VBAで読む
ExcelMemoryMB = 0 ' ここでは設計方針のみ示す
End Function
ネット到達性（Ping簡易チェック）
' ModNetPing.bas
Option Explicit
Public Function PingOk(ByVal host As String) As Boolean
Dim sh As Object: Set sh = CreateObject("WScript.Shell")
Dim rc As Long: rc = sh.Run("cmd /c ping -n 1 " & host, 0, True)
PingOk = (rc = 0)
End Function
導入手順と確認ポイント
手順
- SysInfoシートが自動生成されるか、主要項目が埋まるか確認します。
- ドライブ表にC:/D:のFree/Sizeが出るか、IPが空欄でないか確認します。
- 値が空欄になる項目がある場合、権限や企業ポリシーでの取得制限の可能性があるため、運用PCでの実測を優先します。
確認ポイント
- ExcelBitnessとOS Captionの整合（x64 OSでx86 Excelは珍しくない）。
- 空き容量の閾値設定（5GB/10GBなど）をConfig化して、運用基準に合わせる。
- レポート生成の速度（1秒前後が目安）。遅い場合はWMIクエリ数を減らします。
まとめ：環境を「見える化」すれば、原因追跡は半分終わっている
Excel・OS・ハード・ネットの基本情報を、VBAで一括収集してシートに残すだけで、遅さや不安定の切り分けが劇的に速くなります。Late Bindingで配布を楽にし、WMIでハード・ディスク・IPを、Excel内蔵でビット数・バージョンを、必要に応じてPowerShell併用で深い値を補う——この型が現場では強いです。