简化VBA代码-从列到8*12格式

Question

我是VBA的新手，我想要一些关于简化/使代码更具动态性的建议，这样它就不会特定于特定的范围。我想将同一列中不同行的数据复制到8x12 (x到y)格式。我目前的代码完全正常工作，但我只是想知道是否有一种更动态的方法来做这件事，因为我花了这么多时间才找到循环公式中的关系，它们只固定在384行。我还打算在行为空时退出sub，以防止无限循环。以下是我设法制作的代码：

Private Sub columnto96()

Dim x As Long, y As Long, z As Long, a As Long, lr As Long
Dim src As Worksheet, dst As Worksheet

Set src = Sheet1 'setsheetsource
Set dst = Sheet3 'setsheetdest

lr = src.Cells(Rows.Count, 4).End(xlUp).Row

'for one plate
If lr <= 96 Then
    For y = 1 To 12
        For x = 1 To 8
            dst.Cells(x, y) = src.Cells(8 * y - 8 + x + 1, 4)
        Next x
    Next y
    Exit Sub
    
'for >1 plate
    ElseIf lr > 96 Then
        For y = 1 To 12
           For x = 1 To 8
             dst.Cells(x, y) = src.Cells(8 * y - 8 + x + 1, 4)
           Next x
        Next y
            
        'for more than 96 samples
         For x = 87 To 94
          For y = 1 To 12
           For z = 97 To 104
           dst.Cells(z - x, y) = src.Cells(z, 4)
        
            If z - x >= 17 Then Call nextcolumn Else
            Next z
            
            If src.Cells(lr + 1, 4) = "" Then Exit Sub
            
          Next y
         Next x
        
End If

End Sub

Private Sub nextcolumn()

Dim x As Long, z As Long, y As Long, lr As Long
Dim src As Worksheet, dst As Worksheet

Set src = Sheet1 'setsheetsource
Set dst = Sheet3 'setsheetdest
lr = src.Cells(Rows.Count, 4).End(xlUp).Row

For y = 1 To 12
   For x = 1 To 8
   dst.Cells(x + 9, y) = src.Cells(8 * y + x + 89, 4)
   If src.Cells(8 * y + x + 89, 4) = "" Then Exit Sub
   Next x
Next y

If lr < 289 Or lr >= 193 Then
    For y = 1 To 12
       For x = 1 To 8
       dst.Cells(x + 18, y) = src.Cells(8 * y + x + 184, 4)
       If src.Cells(8 * y + x + 184, 4) = "" Then Exit Sub
       Next x
    Next y
    
    
ElseIf lr >= 289 Or lr < 385 Then
    For y = 1 To 12
        For x = 1 To 8
        dst.Cells(x + 27, y) = src.Cells(8 * y + x + 279, 4)
        If src.Cells(8 * y + x + 279, 4) = "" Then Exit Sub
        Next x
    Next y


Else: Exit Sub

End If

End Sub

提前感谢！:)

Answer 1

获取列集(按列到行的格式)

前两个过程执行相同的操作，并且都使用三个附带的函数。最后一个函数对第一个过程的常量部分和工作表引用中的值执行大部分繁重的lifting.

• Adjust
• 。
• 如果您选择第二个过程，请在找到它们的位置调整这些值。

Option Explicit

Sub getColumnSetsFlexible()
    
    ' Define constants.
    Const sFirst As String = "D2"
    Const dFirst As String = "A2"
    Const rCount As Long = 8
    Const cCount As Long = 12
    Const ByColumns As Boolean = True
    Const includeRemainder As Boolean = False
    Const EmptyRows As Long = 1
    
    ' Create worksheet references.
    Dim sws As Worksheet: Set sws = Sheet1
    Dim dws As Worksheet: Set dws = Sheet3
    
    ' Create a reference to the Source Column Range.
    Dim rg As Range: Set rg = refColumn(sws.Range(sFirst))
    ' Validate Source Column Range.
    If rg Is Nothing Then Exit Sub
    
    ' Write the values from the Source Column Range to Source Data Array.
    Dim sData As Variant: sData = getColumn(rg)
    
    ' Write the column sets from Source Data Array to arrays of Data Array.
    Dim Data As Variant: Data = getColumnSets( _
        sData, rCount, cCount, ByColumns, includeRemainder)
    
    ' Create a reference to the Current Destination Range.
    Dim drg As Range: Set drg = dws.Range(dFirst).Resize(rCount, cCount)
    
    ' Declare Data Array Arrays Counter.
    Dim n As Long
    
    ' Loop through the arrays of Data Array.
    For n = 1 To UBound(Data, 1)
        ' Write the values of the current array of Data Array
        ' to the Current Destination Range.
        drg.Value = Data(n)
        ' Create a reference to the Next Destination Range.
        Set drg = drg.Offset(EmptyRows + rCount)
    Next n

End Sub

Sub getColumnSetsReadable()
    
    ' Create a reference to the Source Column Range.
    Dim rg As Range: Set rg = refColumn(Sheet1.Range("D2"))
    ' Validate Source Column Range.
    If rg Is Nothing Then Exit Sub
    
    ' Write the values from the Source Column Range to Source Data Array.
    Dim sData As Variant: sData = getColumn(rg)
    
    ' Write the column sets from Source Data Array to arrays of Data Array.
    Dim Data As Variant: Data = getColumnSets(sData, 8, 12, True, False)
    
    ' Create a reference to the Current Destination Range.
    Dim drg As Range: Set drg = Sheet3.Range("A2").Resize(8, 12)
    
    ' Declare Data Array Arrays Counter.
    Dim n As Long
    
    ' Loop through the arrays of Data Array.
    For n = 1 To UBound(Data, 1)
        ' Write the values of the current array of Data Array
        ' to the Current Destination Range.
        drg.Value = Data(n)
        ' Create a reference to the Next Destination Range.
        Set drg = drg.Offset(9)
    Next n

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a worksheet column, creates a reference to the range
'               from a given cell 'FirstCellRange' to the bottom-most
'               unoccupied cell i.e. all cells below the latter are empty
'               (="", ="'"... are not included).
'               If `NonBlankInsteadOfNonEmpty` is 'True', the bottom-most cell,
'               whose contents have a length of greater than 0, is condsidered
'               as the bottom-most unoccupied cell i.e. all cells below
'               the latter are blank ('Empty', ="", ="'"...).
' Remarks:      Although 'FirstCellRange' can be a range of any size,
'               only its first cell will be considered.
' Limitations:  If the worksheet contains filtered rows, both options may fail.
'               If it contains hidden rows, then only 'NonBlank' may fail.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function refColumn( _
    FirstCellRange As Range, _
    Optional ByVal NonBlankInsteadOfNonEmpty As Boolean = False) _
As Range
    Const ProcName As String = "refColumn"
    On Error GoTo clearError
    
    If Not FirstCellRange Is Nothing Then
        With FirstCellRange.Cells(1)
            Dim cLookIn As XlFindLookIn
            If NonBlankInsteadOfNonEmpty Then
                cLookIn = xlValues
            Else
                cLookIn = xlFormulas
            End If
            Dim cel As Range
            Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , cLookIn, , , xlPrevious)
            If Not cel Is Nothing Then
                Set refColumn = .Resize(cel.Row - .Row + 1)
            End If
        End With
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values from a column ('ColumnNumber')
'               of a range ('rg') to a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumn( _
    rg As Range, _
    Optional ByVal ColumnNumber As Long = 1, _
    Optional ByVal doTranspose As Boolean = False) _
As Variant
    Const ProcName As String = "getColumn"
    On Error GoTo clearError
    
    If Not rg Is Nothing Then
        If ColumnNumber > 0 And ColumnNumber <= rg.Columns.Count Then
            With rg.Columns(ColumnNumber)
                Dim rCount As Long: rCount = rg.Rows.Count
                Dim Result As Variant
                If rCount > 1 Then
                    If doTranspose Then
                        Dim Data As Variant: Data = .Value
                        ReDim Result(1 To 1, 1 To rCount)
                        Dim r As Long
                        For r = 1 To rCount
                            Result(1, r) = Data(r, 1)
                        Next r
                        getColumn = Result
                    Else
                        getColumn = .Value
                    End If
                Else
                    ReDim Result(1 To 1, 1 To 1): Result(1, 1) = .Value
                    getColumn = Result
                End If
            End With
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values of a 2D one-based one-column array
'               to a jagged array (array of arrays) consisting of arrays
'               of a given number of rows and columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumnSets( _
    ByVal ColumnData As Variant, _
    ByVal RowsCount As Long, _
    ByVal ColumnsCount As Long, _
    Optional ByColumns As Boolean = False, _
    Optional includeRemainder As Boolean = False) _
As Variant
    
    Dim srCount As Long: srCount = UBound(ColumnData, 1)
    Dim fCount As Long: fCount = Int(srCount / (RowsCount * ColumnsCount))
    Dim dRem As Long: dRem = srCount - fCount
    Dim dCount As Long: dCount = fCount
    If includeRemainder Then
        If dRem > 0 Then
            dCount = dCount + 1
        End If
    End If
    
    Dim Data As Variant: ReDim Data(1 To dCount)
    Dim NewData As Variant: ReDim NewData(1 To RowsCount, 1 To ColumnsCount)
    Dim n As Long, r As Long, c As Long, i As Long
    
    If ByColumns Then
        If fCount > 0 Then
            For n = 1 To fCount
                Data(n) = NewData
                For c = 1 To ColumnsCount
                    For r = 1 To RowsCount
                        i = i + 1
                        Data(n)(r, c) = ColumnData(i, 1)
                    Next r
                Next c
            Next n
        End If
        If includeRemainder Then
            If dRem > 0 Then
                Data(n) = NewData
                For c = 1 To ColumnsCount
                    For r = 1 To RowsCount
                        i = i + 1
                        If i <= srCount Then
                            Data(n)(r, c) = ColumnData(i, 1)
                        End If
                    Next r
                Next c
            End If
        End If
    Else
        If fCount > 0 Then
            For n = 1 To fCount
                Data(n) = NewData
                For r = 1 To RowsCount
                    For c = 1 To ColumnsCount
                        i = i + 1
                        Data(n)(r, c) = ColumnData(i, 1)
                    Next c
                Next r
            Next n
        End If
        If includeRemainder Then
            If dRem > 0 Then
                Data(n) = NewData
                For r = 1 To RowsCount
                    For c = 1 To ColumnsCount
                        i = i + 1
                        If i <= srCount Then
                            Data(n)(r, c) = ColumnData(i, 1)
                        End If
                    Next c
                Next r
            End If
        End If
    End If
    
    getColumnSets = Data
    
End Function