VBA - функция, возвращающая массив с каждым элементом, являющимся диапазоном

EDIT: вы можете найти исправленный код под "Исправленный код" ниже

Я изо всех сил пытаюсь понять, как написать функцию VBA, которая вернет массив, где каждый элемент массива является объектом диапазона. В идеале, я хотел бы знать, как писать так, чтобы каждый объект диапазона мог быть несмежным выбором ячеек, в псевдокоде, что было бы примерно так:

***************************** (1) = (A1: C3, A6, B4: B6)

Я нашел эту ветку: Использование массива диапазонов в VBA - Excel Это приближает меня, но я должен делать что-то неправильно в объявлении моей функции (я думаю).

Связка исходного кода была неактуальна в вопросе, поэтому она была удалена, и я сделал простой пример, который возвращает только одну ячейку в каждом элементе массива. Когда я запускаю это, приведенный ниже код возвращает несоответствие типа ByRef в строке:

Set FindLastContentCell(i) = LastCell

Помимо приведенного ниже кода, я попытался сделать объявление функции вариантом (без изменений). Если я удаляю "Set" из строки кода, показанной выше, я получаю "вызов функции в левой части назначения, должен возвращать Variant или Object":

Function FindLastContentCell(Optional WB As Workbook = Nothing, Optional JustWS As Worksheet = Nothing) As Range()

 Dim myLastRow As Long, myLastCol As Long, i As Long
 Dim wks As Worksheet
 Dim dummyRng As Range, LastCell As Range
 Dim AnyMerged As Variant
 Dim Proceed As Boolean
 Dim iResponse As Integer

 ' Initialise variables
 Set LastCell = Nothing
 i = 0

 [Bunch of extra code removed]

 If JustWS Is Nothing Then
 If WB Is Nothing Then Set WB = ActiveWorkbook
 For Each wks In WB.Worksheets

 [Bunch of extra code removed]

 If Proceed Then
 With wks
 myLastRow = 0
 myLastCol = 0
 Set dummyRng = .UsedRange
 On Error Resume Next
 myLastRow = .Cells.Find("*", after:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, _
 searchdirection:=xlPrevious, SearchOrder:=xlByRows).row
 myLastCol = .Cells.Find("*", after:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, _
 searchdirection:=xlPrevious, SearchOrder:=xlByColumns).Column
 End With
 On Error GoTo 0
 Set LastCell = Cells(myLastRow, myLastCol)
 ReDim Preserve FindLastContentCell(0 To i)
 Set FindLastContentCell(i) = LastCell
 i = i + 1 
 End If
 Next wks
 End If

End Function

Вызывающий абонент:

Sub temp()

Call FindLastContentCell

End Sub

Исправленный код

Sub Temp()

Dim rng As Range, results() As Range
Dim x As Variant

results() = FindLastContentCell

End Sub

Function FindLastContentCell(Optional WB As Workbook = Nothing, Optional JustWS As Worksheet = Nothing) As Variant

 'Modded by me

 'From:
 ' http://www.contextures.com/xlfaqApp.html#Unused

 Dim myLastRow As Long, myLastCol As Long
 Dim i As Integer
 Dim wks As Worksheet
 Dim dummyRng As Range, LastCell As Range, LastCells() As Range
 Dim AnyMerged As Variant
 Dim Proceed As Boolean
 Dim iResponse As Integer

 ' Initialise variables
 Set LastCell = Nothing
 i = 0

 ' If the code is only to consider one worksheet passed as JustWS
 ' then determine if something was passed as JustWS
 If JustWS Is Nothing Then
 ' Nothing is found in JustWS, so code runs for each worksheet, either in the passed workbook
 ' object, or else for the ActiveWorkbook
 If WB Is Nothing Then Set WB = ActiveWorkbook
 For Each wks In WB.Worksheets
 ' This is where the code will run from if something was passed as JustWS, otherwise the line below
 ' has no impact on code execution
RunOnce:
 ' Check for merged cells
 AnyMerged = wks.UsedRange.MergeCells
 ' Responde accordingly and let user decide if neccessary
 If AnyMerged = False Then
 Proceed = True
 ElseIf AnyMerged = True Then
 MsgBox "The whole used range is merged. Nothing will be done on this worksheet"
 Proceed = False
 ElseIf IsNull(AnyMerged) Then
 iResponse = MsgBox("There are some merged cells on the worksheet." & vbNewLine & _
 "This might cause a problem with the calculation of the last cells location." & vbNewLine & vbNewLine & _
 "Do you want to proceed anyway?", _
 vbYesNo, _
 "Calculate Last Cell")
 If iResponse = vbYes Then
 Proceed = True
 Else
 Proceed = False
 End If
 Else
 MsgBox "If you this, an error has occured in FindLastContentCell." & vbNewLine & _
 "Code execution has been stopped."
 Stop
 End If

 If Proceed Then
 With wks
 myLastRow = 0
 myLastCol = 0
 Set dummyRng = .UsedRange
 On Error Resume Next
 myLastRow = .Cells.Find("*", after:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, _
 searchdirection:=xlPrevious, SearchOrder:=xlByRows).row
 myLastCol = .Cells.Find("*", after:=.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, _
 searchdirection:=xlPrevious, SearchOrder:=xlByColumns).Column
 End With
 On Error GoTo 0
 Set LastCell = Cells(myLastRow, myLastCol)

 ReDim Preserve LastCells(i)
 Set LastCells(i) = LastCell
 i = i + 1

 ' * This is where code will exit if only a single worksheet is passed.
 ' * Exits if a worksheet object was passed as JustWS, rather than looping through each worksheet
 ' in the workbook variable that was either passed, or which defaults to ActiveWorkbook
 If Not JustWS Is Nothing Then
 FindLastContentCell = LastCells
 Exit Function
 End If

 End If
 Next wks
 ' If a worksheet was passed as JustWS
 Else
 GoTo RunJustOneWS
 End If

 FindLastContentCell = LastCells

 ' Exit upon completion of a workbook variable any code
 ' below here is only run if a worksheet is passed as JustWS
 Exit Function

 ' Setup to run the single worksheet that was passed as JustWS
RunJustOneWS:
 Set wks = JustWS
 GoTo RunOnce

End Function
2 ответа

Из того, что вы говорите, кажется, что у вас нет слишком четких идей относительно Arrays и Ranges в VBA. Здесь у вас есть пример кода, который немного уточняет оба вопроса:

Function getRandomRanges() As Range()

 Dim totRanges As Integer: totRanges = 3
 ReDim outRanges(totRanges - 1) As Range

 Set outRanges(0) = Range("A1")
 Set outRanges(1) = Range("B2:C10")
 Set outRanges(2) = Cells(2, 3)

 getRandomRanges = outRanges

End Function

Вы можете вызвать эту функцию, выполнив:

Dim retrievedRanges() As Range
retrievedRanges = getRandomRanges

Вы можете использовать retrievedRanges по-разному; например:

retrievedRanges(0).Value = "value I want to write in the A1 range"


Я не уверен, чего вы пытаетесь достичь, но насколько я вижу, вы пытаетесь построить массив диапазонов с последней ячейкой каждого рабочего листа книги.

Мое предложение состояло в том, чтобы создать массив временных диапазонов и заполнить его с помощью объектов Range, которые вы хотите, и, наконец, вернуть этот массив temp. Теперь я вижу, что предыдущий ответ "varocarbas" просто предлагает ту же идею

Function FindLastContentCell(Optional xlsWb As Workbook = Nothing, Optional xlsWs As Worksheet = Nothing) As Range()

 Dim myLastRow As Long, myLastCol As Long
 Dim wks As Worksheet
 Dim lastCell As Range
 Dim arrayTmp() As Range
 Dim index As Integer

 [Bunch of extra code removed]

 If xlsWb Is Nothing then
 Set xlsWb = ActiveWorkbook
 End if
 Redim arrayTemp (wks.Worksheets.Count) As Range
 For Each wks in xlsWb.Worksheets
 myLastRow = wks.UsedRange.Rows.Count
 myLastColumn = wks.UsedRange.Columns.Count
 Set lastCell = wks.Cells(myLastRow,myLastColumn)
 Set arrayTemp(index) = lastCell
 index = index + 1
 Next
 Set FindLastContentCell = arrayTemp

End Function

licensed under cc by-sa 3.0 with attribution.