保管用

SELECT文を使う場面では、自然とUPDATE文を使うことが多くなる。

Recordset の UPDATE

テーブルのフィールド「ID」に入力

Option Explicit

Sub writeID()
  Application.Echo False

  Dim recordset As Object
    Set recordset = CreateObject("ADODB.Recordset")
  Dim tableName As String
  Dim sql As String
  Dim i As Long
    i = 1
  
  tableName = InputBox("対象のテーブル名を入力")
  sql = "SELECT * FROM " & tableName
  recordset.Open sql, CurrentProject.connection, , 3
  
  Do Until recordset.EOF
    recordset("ID") = i
    recordset.Update
    recordset.MoveNext
    i = i + 1
  Loop
  recordset.Close
End Sub

テーブルにフィールド「ID」の追加

Sub addIDColumn()
  Dim connection As Object
    'Set connection = CreateObject("ADODB.Connection")
    Set connection = CurrentProject.connection
  Dim tableName As String
    tableName = InputBox("対象のテーブル名を入力")
  
  connection.Execute "ALTER TABLE " & tableName & " ADD ID Long;"
End Sub

Update

Option Explicit

Sub ADO_UPDATE()
  Application.ScreenUpdating = False
  
  Dim updatedTable As Range, updatedField As Range, fromColumn As Range
  Dim SQLCount As Range
  Dim connection As Object
  Dim recordset As Object
  Set updatedTable = Worksheets("SQL").Range("K5")
  Set updatedField = Worksheets("SQL").Range("L5")
  Set fromColumn = Worksheets("SQL").Range("M5")
  Set SQLCount = Worksheets("SQL").Range("N4")
  Set connection = CreateObject("ADODB.Connection")
  Set recordset = CreateObject("ADODB.Recordset")
  Dim selectSQL As String, i As Integer, j As Integer

  'ADO接続
  connection.Provider = "Microsoft.ACE.OLEDB.12.0"
  connection.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=0"
  connection.Open ThisWorkbook.Path & "\" & "Database.xlsx"
    
  For i = 0 To SQLCount - 1
    '対象テーブルのRecordsetを設定
    selectSQL = "SELECT * FROM " & updatedTable.Offset(i, 0).Value
    recordset.Open selectSQL, connection, , 3
  
    'UPDATEの実行
    j = 0
    Do Until recordset.EOF
      recordset(updatedField.Offset(i, 0).Value) = Worksheets("SQL_result").Range(fromColumn.Offset(i, 0).Value & j + 2).Value
      recordset.Update
      recordset.MoveNext
      j = j + 1
    Loop
    
    recordset.Close
  Next

  'メモリの解放（無くとも構わない）
  Set recordset = Nothing
  connection.Close
  Set connection = Nothing
End Sub

SELECT & UPDATE にする。

Sub ADO_SELECT_and_UPDATE()
  Application.ScreenUpdating = False
  
  Dim SQL1st As Range, updatedTable As Range, updatedFields As Range, SQLCount As Range
  Dim updatedFieldsArray
  Dim connection As Object
  Dim recordset As Object, tableRecordset As Object
  Set SQL1st = Worksheets("SQL").Range("R5")
  Set updatedTable = Worksheets("SQL").Range("S5")
  Set updatedFields = Worksheets("SQL").Range("T5")
  Set SQLCount = Worksheets("SQL").Range("U4")
  Set connection = CreateObject("ADODB.Connection")
  Set recordset = CreateObject("ADODB.Recordset")
  Set tableRecordset = CreateObject("ADODB.Recordset")
  Dim selectSQL As String, i As Integer, j As Integer, k As Integer
  
  'ADO接続
  connection.Provider = "Microsoft.ACE.OLEDB.12.0"
  connection.Properties("Extended Properties") = "Excel 12.0;HDR=Yes"
  connection.Open ThisWorkbook.Path & "\" & "Database.xlsx"
  
  Worksheets("SQL_result").Cells.ClearContents
  
  For i = 0 To SQLCount - 1
    updatedFieldsArray = Split(updatedFields.Offset(i, 0).Value, ",")
    'SQL文の実行
    recordset.Open SQL1st.Offset(i, 0).Value, connection
    '対象テーブルのRecordsetを設定
    selectSQL = "SELECT * FROM " & updatedTable.Offset(i, 0).Value
    tableRecordset.Open selectSQL, connection, , 3
    'RecordsetをSQL_resultシートにペーストする
    Worksheets("SQL_result").Range("A2").CopyFromRecordset recordset
    For j = 0 To recordset.Fields.Count - 1
      Worksheets("SQL_result").Cells(1, j + 1).Value = recordset.Fields(j).Name
    Next
    
    'UPDATEの実行
    k = 0
    Do Until tableRecordset.EOF
      For j = 0 To recordset.Fields.Count - 1
        tableRecordset(updatedFieldsArray(j)) = Worksheets("SQL_result").Cells(k + 2, j + 1).Value
        Debug.Print updatedFieldsArray(j), Worksheets("SQL_result").Cells(k + 2, j + 1).Value
      Next
      tableRecordset.Update
      tableRecordset.movenext
      k = k + 1
    Loop
    
    recordset.Close
    tableRecordset.Close
  Next

  'メモリの解放（無くとも構わない）
  Set recordset = Nothing
  Set tableRecordset = Nothing
  connection.Close
  Set connection = Nothing
End Sub

ついでに１つ上に移動してくれるVBS

to_up.vbs

Option Explicit

Dim args, fso, currentDir, parentDir
Dim path, originalFileName

set args = WScript.Arguments
set fso = CreateObject("Scripting.FileSystemObject")
currentDir = fso.GetParentFolderName(WScript.ScriptFullName)
parentDir = fso.GetParentFolderName(currentDir)

for each path in args
    originalFileName = fso.GetFileName(path)
    fso.movefile path, parentDir & "\" & originalFileName
next

VBSでブックのパスワード解除

resolve_xlsx_pass.vbs

Option Explicit

Dim args: Set args = WScript.Arguments
Dim excelObj: Set excelObj = CreateObject("Excel.Application")
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim path, fileName, pass, bookOpened

excelObj.Application.ScreenUpdating = False
For Each path In args
    fileName = fso.GetFileName(path)
    pass = Inputbox("Please EnterKey",fileName)
    If pass = Empty Then
        WScript.Quit	
    End If
    Set bookOpened = excelObj.Workbooks.Open(path, , , ,pass)
    excelObj.DisplayAlerts = False
    bookOpened.SaveAs path, , ""
    bookOpened.Close
    excelObj.DisplayAlerts = True
    MsgBox "resolved PassWord", , fileName
Next
    excelObj.Application.ScreenUpdating = True

to_csv.vbs

Option Explicit

Dim args, fso, excelObj,currentDir, parentDir, path, originalFileName, originalBaseName, fileName, bookOpened, sheetCount
Set args = WScript.Arguments
Set fso = CreateObject("Scripting.FileSystemObject")
Set excelObj = CreateObject("Excel.Application")
currentDir = fso.GetParentFolderName(WScript.ScriptFullName)
'parentDir =  fso.GetParentFolderName(currentDir)

excelObj.Application.ScreenUpdating = False
'excelObj.Application.Visible = True

For Each path in args
    originalFileName = fso.GetFileName(path)
    originalBaseName = fso.GetBaseName(path)	
    Set bookOpened = excelObj.Application.Workbooks.Open(path)
    sheetCount = bookOpened.Worksheets.Count

    fileName = excelObj.Application.GetSaveAsFilename(currentDir & "¥" & originalBaseName & ".csv", "CSVファイル,*.csv", ,originalFileName)
    If fileName = False Then
        MsgBox "ファイル名が指定されていないため作業は中止されます。"
        WScript.Quit
    End If
    excelObj.DisplayAlerts = False	
    If sheetCount = 1 Then
        bookOpened.SaveAs fileName, 6       'xlsx=51, xls=-4143, csv=6
    Else
        MsgBox "このブックは複数のシートを含むのでCSVに変換できませんでした。", ,originalFileName
    End If
    excelObj.DisplayAlerts = True
    bookOpened.Close False
Next

msgbox "Done!!"

excelObj.Application.ScreenUpdating = False
Set excelObj = nothing

integrate_books.vbs

Option Explicit

Dim args: Set args = WScript.Arguments
Dim fso:Set fso = CreateObject("Scripting.FileSystemObject")
Dim excelObj:Set excelObj = CreateObject("Excel.Application")
Dim mergeBook, path, currentBook, currentBookName, sheet, sheetName, protoSheetsCount
Dim currentDir:currentDir = fso.GetParentFolderName(WScript.ScriptFullName)
Dim i, j, N

excelObj.Application.ScreenUpdating = False
'excelObj.Application.Visible = True

Set mergeBook = excelObj.Workbooks.Add 'ブックは新規作成する
protoSheetsCount = mergeBook.Worksheets.Count

i = 0
j = 0
For Each path In args
    currentBookName = fso.GetFileName(path)
    If currentBookName <> "\Integrated.xlsx" And currentBookName  <> mergeBook.Name Then '統合先ブックと同じブック名であればスキップ
      Set currentBook = excelObj.Workbooks.Open(path)
      For Each sheet In currentBook.Worksheets
        sheet.Copy ,mergeBook.Sheets(mergeBook.Worksheets.Count)
        sheetName = Left(Replace(currentBookName, ".xlsx", ""), 10) & "|" & Left(sheet.Name, 20)
        mergeBook.Sheets(mergeBook.Sheets.Count).Name = sheetName
        j = j + 1
      Next
      excelObj.Application.DisplayAlerts = False
      currentBook.Close
      excelObj.Application.DisplayAlerts = True
      i = i + 1
    End If
Next

N = i
excelObj.Application.DisplayAlerts = False
For i = protoSheetsCount To 1 Step -1
  mergeBook.Sheets(i).Delete
Next
mergeBook.SaveAs currentDir & "\Integrated.xlsx"
mergeBook.Close
excelObj.Application.DisplayAlerts = True
  
MsgBox N & "books have been integrated to " & vbCrLf & vbCrLf & "Integrated.xlsx"

excelObj.Application.ScreenUpdating = True

ブック名一覧や移動

Sub show_books()
  Dim usefulBookName As Range, storedBookName As Range
  Dim bookName As String
  Dim i As Integer
  Set usefulBookName = Worksheets("books_list").Range("B2")
  Set storedBookName = Worksheets("books_list").Range("D2")
  Worksheets("books_list").Range("B2:D100").Clear
  
  '同フォルダのブック名を取得
  bookName = Dir(ThisWorkbook.Path & "\*.xlsx") 'フォルダ内のブック名を取得
  i = 0
  Do While bookName <> Empty
    If bookName <> "Database.xlsx" Then
      usefulBookName.Offset(i, 0).Value = Replace(bookName, ".xlsx", "")
      i = i + 1
    End If
    bookName = Dir 'フォルダ内の次のブック名を取得
  Loop
  
  '一時置き場フォルダのブック名を取得
  bookName = Dir(ThisWorkbook.Path & "\一時置き場\*.xlsx") 'フォルダ内のブック名を取得
  i = 0
  Do While bookName <> Empty
    storedBookName.Offset(i, 0).Value = Replace(bookName, ".xlsx", "")
    i = i + 1
    bookName = Dir 'フォルダ内の次のブック名を取得
  Loop
End Sub

Sub move_to_thisfolder()
  Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
  Dim part As Range
  
  For Each part In Selection
    If part.Column = 4 Then
      fso.movefile ThisWorkbook.Path & "\一時置き場\" & part.Value & ".xlsx", ThisWorkbook.Path & "\"
    End If
  Next
  Call show_books
End Sub

Sub move_to_storedfolder()
  Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
  Dim part As Range
  
  For Each part In Selection
    If part.Column = 2 Then
      fso.movefile ThisWorkbook.Path & "\" & part.Value & ".xlsx", ThisWorkbook.Path & "\一時置き場\"
    End If
  Next
  Call show_books
End Sub

ファイル取得

Option Explicit

Private fso As Object

Public path As String

Public Function getFileNames() As Collection
  Dim fileNames As New Collection
  Dim file As Object
  For Each file In fso.GetFolder(path).Files
    fileNames.Add file.name
  Next
  Set getFileNames = fileNames
End Function

Public Function getSubfolderPathes() As Collection
  Dim subfolderPathes As New Collection
  Dim folder As Object
  For Each folder In fso.GetFolder(path).Subfolders
    subfolderPathes.Add folder.path
  Next
  Set getSubfolderPathes = subfolderPathes
End Function

Public Function getDriveName(ByVal path As String) As String
  getDriveName = fso.getDriveName(path)
End Function

Private Sub Class_Initialize()
  Set fso = CreateObject("Scripting.FileSystemObject")
End Sub

Option Explicit

'=============================================
'セル文字列の色を扱うクラス rangeValueColorObj
'=============================================

Private regExp As Object

Public targetRange As Range

Public Function setTargetText(ByVal text As String)
  regExp.Pattern = text
End Function

Public Function changeColor(ByVal colorIndex As Long)
  Dim match As Object
  For Each match In regExp.Execute(targetRange.Value)
    targetRange.Characters(Start:=match.FirstIndex + 1, Length:=match.Length).Font.Color = colorIndex
  Next
End Function

Private Sub Class_Initialize()
  Set regExp = CreateObject("VBScript.RegExp")
  regExp.IgnoreCase = False
  regExp.Global = True
End Sub

Option Explicit

Sub getAllFilesName()
  
  Application.ScreenUpdating = False
  
  Dim folderObj As New safeFolderObj
  Dim rangeValueColor As New rangeValueColorObj 'セル文字列の色を扱うオブジェクト
  
  '===============変数の定義===============================================
  'targetFolderPathes: 調査するフォルダのパスリスト（コレクション）
  'foundSubfolderPathes: 見つけたサブフォルダのパスリスト（コレクション）
  'initialfolderPath: 最初に調査するフォルダパスを記入するセル
  'fileNamePaste､folderPathPaste: ファイル名､フォルダパスをペーストするセル
  '========================================================================
  Dim targetFolderPathes As New Collection
'  Dim foundSubfolderPathes As New Collection
  Dim foundSubfolderPathes As Collection
  Dim initialfolderPath As Range
  Dim fileNamePaste As Range, folderPathPaste As Range
  Dim folderPath As Variant, name As Variant, path As Variant
   
  '=========
  '初期設定
  '=========
  Set initialfolderPath = Worksheets("Sheet1").Range("A1")
  targetFolderPathes.Add initialfolderPath.Value
  Set fileNamePaste = Worksheets("Sheet1").Range("A2")
  Set folderPathPaste = Worksheets("Sheet1").Range("C2")
  
  'Cドライブ以外では実行できないように
  If folderObj.getDriveName(initialfolderPath.Value) <> "C:" Then
    MsgBox "Cドライブ以外では実行できません。"
    Exit Sub
  End If
  
  rangeValueColor.setTargetText "\\" 'rangeValueColorの検索対象を"\"とする
    
  Worksheets("Sheet1").Range("A2:C" & Rows.Count).Clear
  
  '=====
  '実行
  '=====
  Do
  
    '=====================================
    '調査するフォルダのパスリスト に基づき
    'フォルダ１つ１つについて実行
    '=====================================
    For Each folderPath In targetFolderPathes
      folderObj.path = folderPath
      
      'ファイルを取得しセルに記入
      For Each name In folderObj.getFileNames
        fileNamePaste.Value = name
        folderPathPaste.Value = folderPath
        folderPathPaste.Replace initialfolderPath, "" '初期パスの部分は削除
        
        Set rangeValueColor.targetRange = folderPathPaste
        rangeValueColor.changeColor vbBlue '"\"を青色にする
        
        Set fileNamePaste = fileNamePaste.Offset(1, 0)
        Set folderPathPaste = folderPathPaste.Offset(1, 0)
      Next
      
      'サブフォルダを取得し「見つけたサブフォルダのパスリスト」に記入
      Set foundSubfolderPathes = New Collection
      For Each path In folderObj.getSubfolderPathes
        foundSubfolderPathes.Add path
      Next
    Next
    
    '==================================
    '調査するフォルダのパスリストの更新
    '==================================
    
    '「見つけたサブフォルダのパスリスト」で「調査するフォルダのパスリスト」を上書き
    Set targetFolderPathes = foundSubfolderPathes
    '「見つけたサブフォルダのパスリスト」を初期化
    Set foundSubfolderPathes = Nothing
    
  Loop While targetFolderPathes.Count >= 1 '調査するフォルダがあれば次のサイクルへ
  
End Sub

checkPasswordLock.vbs

Option Explicit

Dim args: Set args = WScript.Arguments
Dim excelObj: Set excelObj = CreateObject("Excel.Application")
excelObj.Application.Visible = True
excelObj.Application.ScreenUpdating = False

Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim bookOpened
Dim fileBaseName, beLocked, path, msg
msg = "be locked" & vbCrLf & vbCrLf

For Each path In args
  fileBaseName = fso.GetBaseName(path)
  
  If fso.GetExtensionName(path) = "xlsx" Then
    beLocked = False
  
    On Error Resume Next

    Set bookOpened = excelObj.Workbooks.Open(path, , , , "")
    If Err.number <> 0 Then
      beLocked = True
      bookOpened.Close False
    End If
    
    On Error GoTo 0
    msg = msg & fileBaseName & ": " & beLocked & vbCrLf
  End If
Next

MsgBox msg
excelObj.Quit
Set excelObj = Nothing

範囲を2次元配列としてやり取りしやすくするクラス

workAreaObj.cls

Option Explicit

Private arr As Variant
Public index As Long

Function fromRange(ByRef targetRange As Range)
  arr = targetRange
End Function

Property Get F1() As Variant
  F1 = arr(index, 1)
End Property

Property Get F2() As Variant
  F1 = arr(index, 2)
End Property

Property Let F1(ByVal text As Variant)
  arr(index, 1) = text
End Property

Property Let F2(ByVal text As Variant)
  arr(index, 2) = text
End Property

Function pasteOnSheet(ByRef targetRange As Range)
  targetRange = arr
End Function

複数のブックを、マクロのあるブックに統合する

integrate.bas

Option Explicit

Sub integrate()
    Dim MergeBook As Workbook   '統合先ブック
    Dim CurrentBook As Workbook '作業するブック
    Dim CurrentPath As String  '作業するフォルダのパス
    Dim Filename As String      '作業するファイル名のリスト
    Dim N As Integer            '対象ブック数のカウンタ
    
    Application.ScreenUpdating = False '画面更新を停止
    Set MergeBook = ThisWorkbook 'マクロ実行するブックを統合先ブックとする
    CurrentPath = MergeBook.Path
    Filename = Dir(CurrentPath & "\*.xls") 'フォルダ内のブック名を取得
    Dim sheet As Worksheet
    
    N = 0
    Do While Filename <> Empty
        If Filename <> MergeBook.Name Then '統合先ブックと異なるブック名であれば
            Set CurrentBook = Workbooks.Open(CurrentPath & "\" & Filename)
            For Each sheet In CurrentBook.Worksheets
              sheet.Name = Left(Replace(Filename, ".xlsx", ""), 15) & "|" & Left(sheet.Name, 15)
            Next
            CurrentBook.Worksheets.Copy After:=MergeBook.Sheets(MergeBook.Sheets.Count)
            CurrentBook.Close False
            N = N + 1
        End If
        Filename = Dir 'フォルダ内の次のブック名を取得
    Loop

    MsgBox N & "件のブックを処理しました。"
End Sub

書き出し用のクラス

writableObj.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "writableObj"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private workCollection As New Collection

'workCollectionの各配列インデックスは、ともに１からとする。
Function add(ParamArray pArr() As Variant)
  Dim arr() As Variant
    ReDim arr(1 To (UBound(pArr) - LBound(pArr) + 1))
  Dim i As Integer
  
  For i = 1 To UBound(arr)
    arr(i) = pArr(i - 1)
  Next
  workCollection.add arr
End Function

Function addArray2DByIndex(ByRef array2D() As Variant, ParamArray index() As Variant)
  Dim arr() As Variant, arrByIndex() As Variant
  Dim lb1 As Integer, ub1 As Integer, lb2 As Integer, ub2 As Integer
    lb1 = LBound(array2D): ub1 = UBound(array2D)
    lb2 = LBound(array2D, 2): ub2 = UBound(array2D, 2)
  ReDim arr(1 To (ub1 - lb1 + 1) * (ub2 - lb2 + 1))
  Dim i As Integer, j As Integer
  
  For i = 1 To (ub1 - lb1 + 1)
    For j = 1 To (ub2 - lb2 + 1)
      arr((i - 1) * (ub2 - lb2 + 1) + j) = array2D(lb1 + i - 1, lb2 + j - 1)
    Next
  Next
  
  ReDim arrByIndex(1 To (UBound(index) + 1))
  
  For i = 1 To UBound(arrByIndex)
    arrByIndex(i) = arr(CInt(index(i - 1)))
  Next
  
  workCollection.add arrByIndex
End Function

Function writeOut(ByRef pasteCell As Range)
  Dim writeArr() As Variant
    ReDim writeArr(1 To workCollection.Count, 1 To UBound(workCollection(1)))
  Dim i As Integer, j As Integer
  
  For i = 1 To UBound(writeArr)
    For j = 1 To UBound(writeArr, 2)
      writeArr(i, j) = workCollection(i)(j)
    Next
  Next
  
  pasteCell.Resize(UBound(writeArr), UBound(writeArr, 2)) = writeArr
'  pasteCell.Resize(UBound(writeArr), UBound(writeArr, 2)).Select
End Function

2次元配列を扱いやすくするクラス

array2DObj

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "array2DObj"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private workArray() As Variant 'workArrayのインデックスは、ともに１からとする。

Function fromRange(ByRef targetRange As Range)
  Dim arr As Variant
    arr = targetRange
  workArray = arr
End Function

Function select2(ParamArray index2() As Variant) As array2DObj
  Dim arr() As Variant
    ReDim arr(1 To UBound(workArray), 1 To UBound(index2) + 1)
  Dim i As Integer, j As Integer
  
  For i = 1 To UBound(arr)
    For j = 1 To UBound(arr, 2)
      arr(i, j) = workArray(i, index2(j - 1))
    Next
  Next
  
  ReDim workArray(1 To UBound(arr), 1 To UBound(arr, 2))
  workArray = arr
  
  Set select2 = Me
End Function

Function toArray() As Variant()
  toArray = workArray
End Function

非表示部分を一つずつ表示する

Option Explicit

Sub openNextRowHidden()
  Application.ScreenUpdating = False

  Dim targetRange As Range
    Set targetRange = ActiveSheet.Range("A1:N12")
    
  Static sheetName As String
  Static hiddenRowAreas As Areas
  Static index As Integer
  
  If sheetName <> ActiveSheet.Name Then
    sheetName = ActiveSheet.Name
    Set hiddenRowAreas = getHiddenRowAreas(targetRange)
    index = 0
  End If
        
  If hiddenRowAreas Is Nothing Then
    MsgBox "非表示行はありません。"
  ElseIf (index + 1) > hiddenRowAreas.Count Then
    MsgBox "これ以上の非表示行はありません。" & vbCrLf & "列の方の作業も終了したら、マクロ「checkHiddenLinesCount」を実行して、" & vbCrLf & "非表示部分が残っていない事を確認してください。"
  Else
    index = index + 1
    With hiddenRowAreas(index)
    .EntireRow.Hidden = False
    .EntireRow.Select
    End With
  End If
  
End Sub

Function getHiddenRowAreas(ByRef targetRange As Range) As Areas
  Dim eachHiddenRows As New Collection
  Dim i As Integer
  
  For i = 1 To targetRange.Rows.Count
    If targetRange.Rows(i).Hidden Then
      eachHiddenRows.add targetRange.Rows(i)
    End If
  Next
  
  If eachHiddenRows.Count = 0 Then
    Set getHiddenRowAreas = Nothing
  Else
    Set getHiddenRowAreas = unionAreas(eachHiddenRows)
  End If
End Function

Sub openNextColumnHidden()
  Application.ScreenUpdating = False

  Dim targetRange As Range
    Set targetRange = ActiveSheet.Range("A1:N12")

  Static sheetName As String
  Static hiddenColumnAreas As Areas
  Static index As Integer

  If sheetName <> ActiveSheet.Name Then
    sheetName = ActiveSheet.Name
    Set hiddenColumnAreas = getHiddenColumnAreas(targetRange)
    index = 0
  End If

  If hiddenColumnAreas Is Nothing Then
    MsgBox "非表示列はありません。"
  ElseIf (index + 1) > hiddenColumnAreas.Count Then
    MsgBox "これ以上の非表示列はありません。" & vbCrLf & "行の方の作業も終了したら、マクロ「checkHiddenLinesCount」を実行して、" & vbCrLf & "非表示部分が残っていない事を確認してください。"
  Else
    index = index + 1
    With hiddenColumnAreas(index)
    .EntireColumn.Hidden = False
    .EntireColumn.Select
    End With
  End If

End Sub

Function getHiddenColumnAreas(ByRef targetRange As Range) As Areas
  Dim eachHiddenColumns As New Collection
  Dim i As Integer
  
  For i = 1 To targetRange.Columns.Count
    If targetRange.Columns(i).Hidden Then
      eachHiddenColumns.add targetRange.Columns(i)
    End If
  Next
  
  If eachHiddenColumns.Count = 0 Then
    Set getHiddenColumnAreas = Nothing
  Else
    Set getHiddenColumnAreas = unionAreas(eachHiddenColumns)
  End If
End Function

Function unionAreas(ByRef eachHiddenLines As Collection) As Areas
  Dim unitedRange As Range
  Dim i As Integer
  
  Set unitedRange = eachHiddenLines(1)
  For i = 1 To eachHiddenLines.Count
    Set unitedRange = Union(unitedRange, eachHiddenLines(i))
  Next
  Set unionAreas = unitedRange.Areas
End Function

Sub checkHiddenLinesCount()
  Application.ScreenUpdating = False
  
  Dim targetRange As Range
    Set targetRange = ActiveSheet.Range("A1:N12")
  Dim eachHiddenRows As New Collection
  Dim eachHiddenColumns As New Collection
  Dim i As Integer
  
  For i = 1 To targetRange.Rows.Count
    If targetRange.Rows(i).Hidden Then
      eachHiddenRows.add targetRange.Rows(i)
    End If
  Next
  For i = 1 To targetRange.Columns.Count
    If targetRange.Columns(i).Hidden Then
      eachHiddenColumns.add targetRange.Columns(i)
    End If
  Next
  
  MsgBox "現在非表示行の数は　" & eachHiddenRows.Count & "　です。" & vbCrLf & vbCrLf & "現在非表示列の数は　" & eachHiddenColumns.Count & "　です。"
End Sub