Question

我有31,500个唯一号码的列表。我需要将列表分为4列，每列250个块，然后在前4个循环下循环，并重复该过程直到列表结束。

我已经尝试过，并且只能将列表分为几列，但不能在其下循环。

Sub ExportData(division As Integer)

    Dim cols As New Collection
    Dim rows As New Collection

    Dim counter As Integer
    counter = 0

    Dim fileCounter As Integer
    fileCounter = 0

    Dim fileContent As String
    fileContent = ""

    Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset("select * from activity1")

    Set rows = New Collection

    While Not rs.EOF
        rows.Add rs("Field1").Value
        counter = counter + 1
        If counter = division Then
            fileCounter = fileCounter + 1
            counter = 0
            cols.Add rows
            Set rows = New Collection
        End If
        rs.MoveNext
    Wend

    If counter > 0 Then
        fileCounter = fileCounter + 1
        counter = 0
        cols.Add rows
    End If

    Dim i_col As Integer
    Dim j_row As Integer
    Dim rowText As String

    For j_row = 1 To division
        For i_col = 1 To fileCounter
            On Error Resume Next
            If i_col = fileCounter Then
                rowText = rowText & cols(i_col)(j_row)
            Else
                rowText = rowText & cols(i_col)(j_row) & ","
            End If
        Next
        rowText = rowText & vbCrLf
    Next
End Sub

Example of formatting I'm needing

Answer 1

这应该有效。您可以更改垂直（maxChunk）或水平（maxCol）大小。

Option Explicit

Sub doit()

    Dim rs As adodb.Recordset
    Set rs = New adodb.Recordset
    rs.Open "Select * From activity1 Order By Field1", CurrentProject.Connection, _
         adOpenKeyset, adLockOptimistic

    rs.MoveLast
    rs.MoveFirst

    ' Inhale ALL of the records into an array (base zero)
    Dim varRecords As Variant, maxRecCnt As Long
    varRecords = rs.GetRows(rs.RecordCount, , "Field1") '(rs.RecordCount)
    maxRecCnt = UBound(varRecords, 2)

    Debug.Print maxRecCnt

    Dim x As Long
    ' expected output
    ' A     B   C   D   E   F   G   H
    ' 1     6   11  16  21  26  31  36
    ' 2     7   12  17  22  27  32  37
    ' 3     8   13  18  23  28  33  38
    ' 4     9   14  19  24  29  34  39
    ' 5     10  15  20  25  30  35  40
    '41

    Dim allText As String

    Dim maxChunk As Long, rowInChunk As Long, numChunk As Long
    maxChunk = 5
    rowInChunk = 0

    Dim maxCol As Long, numCol As Long
    maxCol = 8
    numCol = 0

    For numChunk = 1 To maxRecCnt / maxChunk * maxCol
            For rowInChunk = 1 To maxChunk

                    Dim rowText As String
                    rowText = ""
                    For numCol = 1 To maxCol
                        ' compute which cell in the array we want
                        x = ((numCol - 1) * maxChunk) + rowInChunk - 1 + ((numChunk - 1) * maxChunk * maxCol)
                        On Error Resume Next  ' widows at the end
                        rowText = rowText & vbTab & varRecords(0, x)
                    Next numCol

                    'MsgBox (rowText)
                    allText = allText & vbCrLf & rowText

            Next rowInChunk
            allText = allText & vbCrLf

    Next numChunk

    MsgBox (allText)

End Sub

如何使用VBA将数据列表分类为特定的行/列？

1 个答案: