Создавайте массив диапазонов, когда диапазон слишком велик

Question

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

Я также готов отказаться от идеи разделения столбца и просто иметь что-то вроде for each 444 rows, create rng. Затем for each rng in rng.arry Сделайте XYZ.

Обновление: в основном у меня есть строка с 1000 значениями. Я хотел бы иметь массив диапазонов в таком формате:

rng(0) = A1:A444
rng(1) = A445:A889
rng(2) = A890:A1000

Тогда я могу l oop через каждый rng следующим образом:

For each rng in rng.array
   ... Do Stuff
End For

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

 Sub Four_Hundred_Fourty_Four_Split_Sub()
Dim lastRow As Long, copynumRow As Long
Dim cRow As Long, cCol As Long
Dim wb As Workbook, ws As Worksheet
Dim rng As Range

If IsEmpty(urng) = False Then
Debug.Print urng
Set urng = Application.InputBox("Select a range", "Obtain Range Object", Type:=8)
End If
Set rng = Range(Col_Letter(urng.Column) & "1:" & Col_Letter(urng.Column) & Cells(Rows.Count, urng.Column).End(xlUp).Row)

Set wb = ActiveWorkbook
Set sSheet = ActiveSheet

WorksheetCreate ("444_Split")
Set ws = wb.Worksheets("444_Split")
sSheet.Select


rng.Copy Destination:=ws.Range(Col_Letter(urng.Column) & "1:" & Col_Letter(urng.Column) & Cells(Rows.Count, urng.Column).End(xlUp).Row)

Application.ScreenUpdating = False

copynumRow = 444
cCol = 2
cRow = 1 + copynumRow

With ws
    lastRow = .Range("A" & .Rows.Count).End(xlUp).Row

    Do While cRow <= lastRow
        .Range("A" & cRow).Resize(copynumRow, 1).Cut _
            Destination:=.Cells(1, cCol).Resize(copynumRow, 1)

        cRow = cRow + copynumRow
        cCol = cCol + 1
    Loop
End With

Application.ScreenUpdating = True

ws.Select

End Sub

Answer 1

Я набросал кое-что, что работает для вашего примера. Я добавил несколько комментариев, чтобы объяснить, но не тестировал их полностью.

Я бы посоветовал использовать более значимые имена переменных et c.

Это создает массив диапазонов, который затем можно перенести обратно на рабочий лист.

Sub x()

Dim r As Range, rStart As Range
Dim n As Long, i As Long, j As Long
Dim r1() As Range

n = 444

Set r = Range("A1:A1000")
ReDim r1(1 To WorksheetFunction.Ceiling(r.Count / n, 1)) 'work out how many groups of 444

For i = 1 To UBound(r1)
    Set rStart = r.Cells((i - 1) * n + 1) 'starting cell of each array element
    If r(r.Rows.Count).Row - rStart.Row < n Then    'check if less than 444 rows left
        j = r(r.Rows.Count).Row - rStart.Row + 1
    Else
        j = n
    End If
    Set r1(i) = rStart.Resize(j) 'expand group to full size and add to array
    Debug.Print r1(i).Address
Next i

End Sub

Answer 2

Пожалуйста, проверьте и следующий код. Протестируйте его на новом пустом листе, где он построит тестовый диапазон из 1000 строк для выбранного вами столбца и вернет каждый диапазон массивов в других столбцах, начиная с 5-го:

Sub testRangesArray()
  Dim sh As Worksheet, arrR As Variant, lastRow As Long, Lcol As String, splitVal As Long
  Dim i As Long, k As Long, rng As Range
  
  Set sh = ActiveSheet
  Lcol = "B" 'Column to be processed/tested letter
  'Create a test range in the test column________________________________________________
    With sh.Range(Lcol & "2:" & Lcol & 3)
        .Value = Application.Transpose(Array(1, 2))
        .AutoFill Destination:=sh.Range(Lcol & "2:" & Lcol & "1001"), Type:=xlFillDefault
    End With
  '______________________________________________________________________________________
  
  lastRow = sh.Range(Lcol & Rows.count).End(xlUp).row
  Set rng = sh.Range(Lcol & "2:" & Lcol & lastRow)
  splitVal = 444 'you may set here what you need

  ReDim arrR(WorksheetFunction.RoundUp(rng.Rows.count / splitVal, 0) - 1)
  For i = 0 To UBound(arrR)
    Set arrR(i) = Range(Lcol & IIf(i = 0, rng.Cells(1).row, splitVal * i + rng.Cells(1).row) & ":" & _
                          IIf(i = UBound(arrR), Lcol & rng.Rows.count + rng.Cells(1).row - 1, Lcol & _
                                                            splitVal * (i + 1) + rng.Cells(1).row - 1))
  Next i
  'Drop the array ranges values in columns, starting from the 5th one:
  For i = 0 To UBound(arrR)
    sh.Cells(1, 5 + i).Resize(arrR(i).Rows.count, 1).Value = arrR(i).Value
  Next
End Sub

Answer 3

Вот то, что я сейчас использовал в конце моего кода выше, но я не говорю, что это вообще лучший способ ....

WS.Select
Call FindLast(WS)

Dim rcell As Range

Set rng = Application.ActiveSheet.Range("A1:" & lColLet & "1")

For Each rcell In rng.Cells
 If Not IsError(rcell.Value) Then
  If rcell.Value <> "" Then
    Set IDRng = WS.Range(rcell.Address, rcell.End(xlDown))
    Call PasteInWV
  End If
 End If
Next rcell

Application.ScreenUpdating = True