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

然后我可以像这样循环遍历每个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

我草绘了一些内容，适用于您的示例。我添加了一些注释来解释，但是还没有进行彻底的测试。

我建议使用更有意义的变量名等。

这将生成一系列范围，然后可以将其转移回工作表。

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

这是我上面的代码底部现在最终使用的内容，但是我并不是说这是最好的方法...。

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

Answer 3

请也测试下一个代码。在一个新的空白表上对其进行测试，它将为您选择的一列构建一个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

当范围太大时，使范围数组

3 个答案: