我对VBA很陌生，我想要一些关于简化/使代码更动态的建议，这样它就不会局限于特定的范围。我想将同一列中的数据从不同的行复制到8 x 12(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
提前感谢！：(
获取列集(逐列逐行格式(
- 前两个过程执行相同的操作，并且都使用了附带的三个函数
- "节目之星"是最后一个承担大部分重任的角色
- 调整第一个过程的常量部分和工作表引用中的值
- 如果选择第二个过程，请调整找到它们的位置的值
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