Copy Every So Many Rows to New Sheet Column A, B, etc-CodePudding

I was wondering if it would be possible in excel vba to copy every 950 rows to a new sheet & then a new sheet's column?

Ex: If there were over 4000 rows in column A Sheet1 to then move every 950 rows to Sheet2 Column A, Next 950 rows to Sheet2 Column B, etc.

I've seen some answers involving Transpose but not sure if that would work since it would be still going vertical to vertical. I would still like it to go vertical so Sheet2 Column A would be rows A1 - A949, Column B would be A1 - A949, etc.

Thanks for your help!

I've tried Transpose but instead of putting it into columns vertically, it still does the rows horizontal so instead of moving to column A Sheet2 rows 1-949, it was doing A1 - H1 (I've been testing on small datasets)

Is there a better method than transpose? Right now I'm currently dragging & selecting the rows manually to paste into the new sheet & column which does not seem efficient.

CodePudding user response：

Single Column To Columns

Utilization

Sub ColToColsTEST()

    Const ROWS_PER_COLUMN As Long = 6

    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Sheet1")
    Dim srg As Range
    Set srg = sws.Range("A2", sws.Cells(sws.Rows.Count, "A").End(xlUp))
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Sheet2")
    Dim dfCell As Range: Set dfCell = dws.Range("A2")
    
    ColToCols srg, dfCell, ROWS_PER_COLUMN
    
End Sub

The Method

Sub ColToCols( _
        ByVal SourceSingleColumnRange As Range, _
        ByVal DestinationFirstCell As Range, _
        ByVal RowsPerColumn As Long)
    
    ' Write the values from the Source range to the Source array.
    
    Dim sData() As Variant, srCount As Long
    
    With SourceSingleColumnRange.Columns(1)
        srCount = .Rows.Count
        If srCount = 1 Then
            ReDim sData(1 To 1, 1 To 1): sData(1, 1) = .Value
        Else
            sData = .Value
        End If
    End With
    
    ' Define the Destination array.
    
    Dim dcCount As Long: dcCount = Int(srCount / RowsPerColumn)
    Dim ldrCount As Long: ldrCount = srCount Mod RowsPerColumn
    
    Dim drCount As Long
    
    If dcCount = 0 Then drCount = ldrCount Else drCount = RowsPerColumn
    If ldrCount > 0 Then dcCount = dcCount   1
    
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' Write from the Source To the Destination array: all but the last column.
    
    Dim sr As Long, dr As Long, dc As Long
    
    For dc = 1 To dcCount - 1
        For dr = 1 To drCount
            sr = sr   1
            dData(dr, dc) = sData(sr, 1)
        Next dr
    Next dc
    
    ' Write from the Source To the Destination array: the last column.
    
    If ldrCount = 0 Then ldrCount = drCount
    
    For dr = 1 To ldrCount
        sr = sr   1
        dData(dr, dc) = sData(sr, 1)
    Next dr
    
    ' Write the values from the Destination array to the Destination range.
    
    With DestinationFirstCell
        .Resize(drCount, dcCount).Value = dData
    End With
    
End Sub