Converting a row to multiple columns in excel-CodePudding

I have an excel file with one row and 11000 columns. It's a 1x11000 matrix. I want to convert it to rows with 17 columns (n x 17 matrices). What should I do? Thanks in advance.

As of yet, I haven't found a solution.

CodePudding user response：

Single Row to Rows

Sub SingleRowToRows()
    
    Const SOURCE_WORKSHEET_NAME As String = "Sheet1"
    Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
    Const SOURCE_COLUMNS_COUNT As Long = 10
    
    Const DEST_WORKSHEET_NAME As String = "Sheet1"
    Const DEST_FIRST_CELL_ADDRESS As String = "A3"
    Const DEST_COLUMNS_COUNT As Long = 3
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_WORKSHEET_NAME)
    Dim sfCell As Range: Set sfCell = sws.Range(SOURCE_FIRST_CELL_ADDRESS)
    Dim srg As Range: Set srg = sfCell.Resize(, SOURCE_COLUMNS_COUNT)
    Dim sData() As Variant: sData = srg.Value
    
    Dim drCount As Long
    drCount = Int(SOURCE_COLUMNS_COUNT / DEST_COLUMNS_COUNT)
    
    Dim Remainder As Long
    Remainder = SOURCE_COLUMNS_COUNT Mod DEST_COLUMNS_COUNT
    
    If Remainder > 0 Then drCount = drCount   1
    
    Dim dData() As Variant
    ReDim dData(1 To drCount, 1 To DEST_COLUMNS_COUNT)
    
    Dim dr As Long: dr = 1
    
    Dim sc As Long
    Dim dc As Long
    
    For sc = 1 To SOURCE_COLUMNS_COUNT
        
        If dc < DEST_COLUMNS_COUNT Then
            dc = dc   1
        Else
            dr = dr   1
            dc = 1
        End If
        
        dData(dr, dc) = sData(1, sc)
    
    Next sc
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(DEST_WORKSHEET_NAME)
    Dim dfCell As Range: Set dfCell = dws.Range(DEST_FIRST_CELL_ADDRESS)
    Dim drg As Range: Set drg = dfCell.Resize(drCount, DEST_COLUMNS_COUNT)
    
    drg.Value = dData
    
End Sub

CodePudding user response：

I've got 1 to 101 in row 1. Here's the result, after the code runs.

Public Sub TransposeData()

    Dim xLRow As Long
    Dim xNRow As Long
    Dim i As Long
    Dim xUpdate As Boolean
    Dim xRg As Range
    Dim xOutRg As Range
    Dim xTxt As String
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select data range(only one column):", "Excel", xTxt, , , , , 8)
    Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
    If xRg Is Nothing Then Exit Sub

    Set xOutRg = Application.InputBox("please select output range(specify one cell):", "Excel", xTxt, , , , , 8)
    If xOutRg Is Nothing Then Exit Sub
    Set xOutRg = xOutRg.Range(1)
    xUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    xLCol = xRg.Columns.Count
    xNRow = 3
    xNCol = 1
    For i = 1 To xLCol Step 17
        xRg.Cells(i).Resize(1, 17).Copy
        xOutRg.Offset(xNRow, xNCol).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        xNCol = xNCol   1
    Next
    Application.ScreenUpdating = xUpdate
    
End Sub