Sub SplitColumns()
    Const nROWS = 1700
    
    Dim rInp As Range
    On Error Resume Next
    Set rInp = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rInp Is Nothing Then Exit Sub
    
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Dim yy As Long
    For yy = 1 To rInp.Rows.Count Step nROWS
        rInp.Cells(yy, 1).Resize(nROWS, rInp.Columns.Count).Copy rOut
        Set rOut = rOut.Cells(1, rInp.Columns.Count + 2)
    Next
End Sub