Как добавить цикл на 250 ячеек и сместить массив?

Question

У меня есть этот код, который просматривает столбец A и циклически перебирает его, чтобы создать массив для вставки в другое место назначения, но я хочу манипулировать им, чтобы циклически проходить через наборы из 250 ячеек, создавать объединенный массив и печатать его в ячейки B1. После этого набора 250 я иду в ячейки a251-a501 и т. Д., Пока не достигну конца списка, и у каждого набора из 250 объединенных идентификаторов (разделенных знаком «;») будет напечатана следующая строка назначения (B1> B2> B3 и т. Д.)

Sub JC_Fill()

Dim varArray() As Variant
Dim x As Long, i As Long

i = 0
x = 1

With ThisWorkbook.Worksheets("Sheet1").UsedRange.Rows.Count

    ReDim varArray(1)                        'resize array

    Do Until Cells(x, 1).Value = ""

        If Cells(x, 1) <> "" Then
            varArray(i) = Cells(x, 1).Value
            i = i + 1
            ReDim Preserve varArray(i)
        End If

        x = x + 1
    Loop



    ReDim Preserve varArray(i - 1)

End With

ThisWorkbook.Worksheets("Sheet1").Range("B1").Value = varArray



End Sub

Как я могу отредактировать Do While/Loop, чтобы повторять процесс каждые 250 ячеек, а затем объединить массив в одну ячейку, разделенную ;, а затем сместить следующий пакет, пока у меня не останется больше идентификаторов для циклического перехода?

Answer 1

Для интереса вы можете сделать это без зацикливания каждой из 250 ячеек.

Sub x()

Dim n As Long, v As Variant, r As Range, n2 As Long

n = 5 '250 for you
n2 = Range("A" & Rows.Count).End(xlUp).Row

Set r = Range("A1").Resize(n)
Do While Len(r(1)) > 0
    If n2 - r(1).Row < n Then Set r = r.Resize(n2 - r(1).Row + 1)
    If r.Count = 1 Then
        v = r.Value
    Else
        v = Join(Application.Transpose(r), ";")
    End If
    Range("B" & Rows.Count).End(xlUp)(2).Value = v
    Set r = r.Offset(n)
Loop

End Sub

Answer 2

Попробуйте изменить код следующим образом:

Sub JC_Fill()

Dim OutString
Dim x As Long, i As Long

Dim out_row As Long

i = 0
x = 1
out_row = 1


With ThisWorkbook.Worksheets("Sheet1").UsedRange.Rows.Count

    OutString = ""

    Do Until Cells(x, 1).Value = ""

        If Cells(x, 1) <> "" Then
            If (x > 1) Then OutString = OutString & ";"
            OutString = OutString & Cells(x, 1).Value
        End If


        If (x Mod 250) = 0 Then
          ThisWorkbook.Worksheets("Sheet1").Range("B" & out_row).Value = OutString
          OutString = ""
          out_row = out_row + 1
        End If

        x = x + 1

    Loop

End With

ThisWorkbook.Worksheets("Sheet1").Range("B" & out_row).Value = OutString



End Sub