ExcelのRange.Areasに多数のセル領域をセット

0.README.md

[Excel] Range.Areas に多数のセル領域をセットするためのクラスモジュール

Range.Areas に多数のセル領域を（統合されることなく）セットするためのクラスモジュール例。
※ Union だと統合されてしまう／Range.Address には一定長以上の文字列はセットできない、という制限を、名前(Workbook.Names)経由で設定することで回避する試み。

クラスモジュール

1. AreaCollection.vba

テスト用モジュール

1. Test_AreaCollection.vba

AreaCollection.vba

Option Explicit

Private Const NameLengthLimit = 260 ' Name.RefersTo に設定可能な長さ

Private NamePrefix As String
Private NameNumber As Long
Private TargetWorkbook As Workbook
Private ClearNamesAuto As Boolean
Private AddSheetPrefix As Boolean
Private IsRowAbsolute As Boolean
Private IsColumnAbsolute As Boolean
Private FirstRange As Range
Private AreaAddresses() As String
Private LastCollectedAddressIndex As Long

Public Sub Init( _
    Optional targetBook As Workbook, _
    Optional clearStoredNames As Boolean = False, _
    Optional clearAuto As Boolean = True, _
    Optional storedNamePrefix As String = "_", _
    Optional sheetPrefix As Boolean = False, _
    Optional absoluteRow As Boolean = True, _
    Optional absoluteColumn As Boolean = True _
)
    NamePrefix = storedNamePrefix
    NameNumber = 0
    If targetBook Is Nothing Then Set targetBook = ActiveWorkbook
    Set TargetWorkbook = targetBook
    ClearNamesAuto = clearAuto
    AddSheetPrefix = sheetPrefix
    IsRowAbsolute = absoluteRow
    IsColumnAbsolute = absoluteColumn
    Set FirstRange = Nothing
    ReDim AreaAddresses(0)
    LastCollectedAddressIndex = 0
    
    If clearStoredNames Then Clear ' TODO: 既存の名前削除には時間がかかる
End Sub

Public Sub Clear()
    Dim savedCalculation As Long: savedCalculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim currentName As Name
    Dim reg As Object: Set reg = CreateObject("VBScript.RegExp")

    With reg
        .Global = True
        .Pattern = "(?:^|!)" & NamePrefix & "\d+$"
    End With

    On Error Resume Next
    For Each currentName In TargetWorkbook.Names
        If 0 < reg.Execute(currentName.Name).Count Then currentName.Delete
    Next
    On Error GoTo 0
    
    NameNumber = 0
    LastCollectedAddressIndex = 0
    
    Application.Calculation = savedCalculation
End Sub

Public Sub AddArea(addCells As Range)
    If Not addCells.Worksheet.Parent Is TargetWorkbook Then
        Err.Raise 8888, addCells, "Specified areas do not belong to target workbook"
        Exit Sub
    End If
    
    Dim sheetPrefix As String
    Dim cellRange As Range
    Dim addressIndex As Long: addressIndex = UBound(AreaAddresses)
    
    ReDim Preserve AreaAddresses(UBound(AreaAddresses) + addCells.Areas.Count)
    
    If FirstRange Is Nothing Then Set FirstRange = addCells
    
    For Each cellRange In addCells.Areas
        addressIndex = addressIndex + 1
        sheetPrefix = IIf(AddSheetPrefix, "'" & cellRange.Worksheet.Name & "'!", "")
        AreaAddresses(addressIndex) = sheetPrefix & cellRange.Address(IsRowAbsolute, IsColumnAbsolute)
    Next
End Sub

Public Property Get CollectedRange() As Range
    Dim savedCalculation As Long: savedCalculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    If UBound(AreaAddresses) = LastCollectedAddressIndex Then GoTo SET_RESULT
    
    Dim addressIndex As Long
    Dim nameLength As Long
    Dim currentAddress As String
    Dim nameParts() As String
    Dim setIndex As Long
        
    nameLength = 0
    ReDim nameParts(1 To UBound(AreaAddresses))
    setIndex = 0
    
    If LastCollectedAddressIndex = 0 Then
        NameNumber = 0
    Else
        nameParts(1) = NamePrefix & NameNumber
        nameLength = Len(nameParts(1)) + 1
        setIndex = 1
    End If
    
    For addressIndex = LastCollectedAddressIndex + 1 To UBound(AreaAddresses)
        currentAddress = AreaAddresses(addressIndex)
        nameLength = nameLength + Len(currentAddress) + 1 ' +1 は "=" もしくは "," の分
        
        If nameLength <= NameLengthLimit Then
            setIndex = setIndex + 1
            nameParts(setIndex) = currentAddress
        Else
            ReDim Preserve nameParts(1 To setIndex)
            NameNumber = NameNumber + 1
            setAreaName NamePrefix & NameNumber, "=" & Join(nameParts, ",")
            ReDim nameParts(1 To UBound(AreaAddresses))
            nameParts(1) = NamePrefix & NameNumber
            nameParts(2) = currentAddress
            nameLength = Len(nameParts(1)) + Len(currentAddress) + 2
            setIndex = 2
        End If
    Next
    
    If 0 < setIndex Then
        ReDim Preserve nameParts(1 To setIndex)
        NameNumber = NameNumber + 1
        setAreaName NamePrefix & NameNumber, "=" & Join(nameParts, ",")
    End If
    
    LastCollectedAddressIndex = UBound(AreaAddresses)
    
SET_RESULT:
    If 0 < NameNumber And FirstRange.Worksheet.Parent Is TargetWorkbook Then
        Set CollectedRange = FirstRange.Worksheet.Range(NamePrefix & NameNumber)
    Else
        Set CollectedRange = Nothing
    End If
    
    If ClearNamesAuto Then Clear
    Application.Calculation = savedCalculation
End Property

'Private Sub setAreaName(key As String, value As String)
'    On Error Resume Next
'    TargetWorkbook.Names(key).Delete
'    TargetWorkbook.Names.Add Name:=key, RefersTo:=value
'    On Error GoTo 0
'End Sub

Private Sub setAreaName(key As String, value As String)
    On Error GoTo ADD_NAME
    TargetWorkbook.Names(key).RefersTo = value
    Exit Sub

ADD_NAME:
    TargetWorkbook.Names.Add Name:=key, RefersTo:=value
End Sub

Private Sub Class_Initialize()
    Init
End Sub

Private Sub Class_Terminate()
    Clear
End Sub

Test_AreaCollection.vba

Option Explicit

Sub Test_AreaCollection()
    ThisWorkbook.Activate
    
    Dim ac As New AreaCollection
    Dim counter As Long
    Dim maxNumber As Long: maxNumber = 10000
    Dim resultRange As Range
    
    Dim startTime As Double
    Dim markTime As Double
    Dim stopTime As Double
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    'Application.Calculation = xlCalculationManual
    
    With ac
        .Init clearAuto:=False
        ' clearAuto: .CollectedRange 取得時 Names を自動クリア(True:する／False:しない)
        
        ActiveSheet.Cells.Interior.ColorIndex = 0
        
        startTime = Timer
        markTime = startTime
        
        .AddArea Range("A1")
        .AddArea Range("A2")
        .AddArea Range("A3")
        .AddArea Range("B3")
        .AddArea Range("A4")
        .AddArea Range("C1")
        .AddArea Range("C4")
        .AddArea Range("A5:C5")
        .AddArea Range("A6:C6")
        
        Set resultRange = .CollectedRange
        resultRange.Select
        Debug.Print "(*) Areas: " & resultRange.Areas.Count & " Names: " & ActiveWorkbook.Names.Count

        For counter = 10 To maxNumber
            .AddArea Cells(counter, 1 + counter Mod 10)
        Next

        Debug.Print "AddArea: " & Format$(Timer - markTime, "0.00") & " sec."
        markTime = Timer
        
        Set resultRange = .CollectedRange
        resultRange.Interior.Color = RGB(255, 255, 0)
        resultRange.Select
        
        stopTime = Timer
        Debug.Print "Collect: " & Format$(stopTime - markTime, "0.00") & " sec."
        Debug.Print "Total  : " & Format$(stopTime - startTime, "0.00") & " sec."
        Debug.Print "(*) Areas: " & resultRange.Areas.Count & " Names: " & ActiveWorkbook.Names.Count
        'Debug.Print "    Address: " & resultRange.Address
        Debug.Print String(80, "-")
    End With
    
    'Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

■ 元ネタ

• ことりちゅん@えくせるちゅんちゅんさんはTwitterを使っています: 「危ない危ない。危うくバグを混入させるところだった。 ＜SelectするつもりのRangeは、Unionで合成してはならない＞ 問題はRangeに渡せるアドレス文字列が(確か)255文字までという制限があることなんだよね。 大量のセルを安全に連結させる方法が知りたい・・・。 https://t.co/wYxNtojj5U」 / Twitter
• ことりちゅん@えくせるちゅんちゅんさんはTwitterを使っています: 「隣接したセル領域をAreasで取り出せるようにバラバラにRangeに格納したいのですが、Address使うしか無いんですよね？ 今回、結構な量のセルを格納したくて256文字制限を超えてしまったため、どうにかしてくっつける方法は無いのかと模索中です。 https://t.co/UpINbWQQoI」 / Twitter

■ 関連

• Unionを使わずにRangeを合成する実験 – Dropbox Paper
• 風柳さんはTwitterを使っています: 「@KotorinChunChun 名前はメモリの許す限り定義できるみたいなので、これでも良いかも知れませんね…。 https://t.co/V4Rhv6fbh0 https://t.co/xgUQVYGPDa」 / Twitter