需要VBA代码将Excel工作表列转换为新Excel工作表中的选项卡

Question

I have an Excel sheet having 3000 columns and I need to convert this sheet in such a way that one tab will contain 254 columns only and remaining will go to the next tab. So I need a VBA code (Macro) which can perform the same.

As of now I wrote the following code only which is creating 3000 tabs with one column in each, also it is going to infinite loop as I did not put any condition there for blank column.

Sub SpliteIntoMultipleTab()
    '
    ' createtemplates Macro
    Dim WS As Worksheet
    Dim SS As Worksheet
    Dim TemplateName As String
    Dim tempstr As String
    '
    Dim CurCol As String
    Dim Template As String
    Dim xColIndex As Integer
    Dim xRowIndex As Integer
    Dim WSCount As Integer
    '==========================================================================
    'Declarations
    CurCol = 1
    Template = "Sheet1"
    '==========================================================================
    Set SS = Worksheets(Template)
    If WS Is Nothing Then

Start:

    With ActiveWorkbook
        Set WS = .Sheets.Add(After:=ActiveSheet)
        WSCount = Sheets.Add(After:=Sheets(Worksheets.Count))
        On Error Resume Next
        Set WS = Worksheets("temp")
        WS.Name = SS.Range("A1").Value
      End With
    Else
    End If

    SS.Activate
    xIndex = Application.ActiveCell.Column
    xRowIndex = Application.ActiveSheet.Cells(Rows.Count, xIndex).End(xlUp).Row
    Range(Cells(1, xIndex), Cells(xRowIndex, xIndex)).Select
    Selection.Copy
    WS.Select
    WS.Range("A1").Select
    ActiveSheet.Paste
    SS.Columns(1).EntireColumn.Delete
    CurCol = CurCol + 1
    GoTo Start
End Sub

Answer 1

Use integer division and modulus, so for example taking the 1000th column

1000 \ 254 = 3 

1000 mod 254 = 238 

gives the 3rd sheet and the 238th column.

So loop through from 1 to 3000 using \\ and mod .

You code is very non-standard and I cannot get my head around it, I suggest you start from my code, this is an illustrative example of breaking a block of data into separate sheets. Copy the code into a new workbook then

Run CreateSheetAndPopulateWithBlockOfData once only to create a block of data. Run Test to run the BreakBlockIntoChunks routine, you can experiment with the chunk size.

Option Explicit

Private Const csSHEETNAME As String = "Source"

Sub TestCreateSheetAndPopualteWithBlockOfData()

    Dim wsSource As Excel.Worksheet
    Set wsSource = CreateSheetAndPopulateWithBlockOfData(ThisWorkbook, csSHEETNAME, 20, 100)

End Sub

Sub Test()
    Dim wsSource As Excel.Worksheet
    Set wsSource = ThisWorkbook.Worksheets.Item(csSHEETNAME)


    'Stop
    Dim wbResults As Excel.Workbook
    Set wbResults = Workbooks.Add
    BreakBlockIntoChunks wsSource, 5, wbResults
End Sub

Function BreakBlockIntoChunks(ByVal wsSource As Excel.Worksheet, ByVal lColumnChunkSize As Long, ByVal wbDestinationWorkbook As Excel.Workbook)

    Dim rngDataBlock As Excel.Range
    Set rngDataBlock = wsSource.Cells(1, 1).CurrentRegion

    Dim lSourceColumnCount As Long
    lSourceColumnCount = rngDataBlock.Columns.Count

    Dim lSourceRowCount As Long
    lSourceRowCount = rngDataBlock.Rows.Count

    Dim lColumnLoop As Long
    For lColumnLoop = 1 To lSourceColumnCount

        Dim lCurrentSheet As Long
        lCurrentSheet = ((lColumnLoop - 1) \ lColumnChunkSize) + 1

        Dim wsCurrentSheet As Excel.Worksheet

        If lCurrentSheet > wbDestinationWorkbook.Worksheets.Count Then Set wsCurrentSheet = wbDestinationWorkbook.Worksheets.Add

        If wsCurrentSheet Is Nothing Then Set wsCurrentSheet = wbDestinationWorkbook.Worksheets.Item(lCurrentSheet) '* runs first loop


        '**ADD your sheet naming logic here perhaps

        Dim lCurrentColumn As Long
        lCurrentColumn = ((lColumnLoop - 1) Mod lColumnChunkSize) + 1


        Dim rngSource As Excel.Range
        Set rngSource = wsSource.Range(wsSource.Cells(1, lColumnLoop), wsSource.Cells(lSourceRowCount, lColumnLoop))

        Dim rngDestination As Excel.Range
        Set rngDestination = wsCurrentSheet.Range(wsCurrentSheet.Cells(1, lCurrentColumn), wsCurrentSheet.Cells(lSourceRowCount, lCurrentColumn))

        rngDestination.Value2 = rngSource.Value2 '* <---Copies without using clipboard



    Next lColumnLoop



End Function

Function CreateSheetAndPopulateWithBlockOfData(ByVal wb As Excel.Workbook, ByVal sSheetName As String, ByVal lRowsDeep As Long, ByVal lColumnsWide As Long) As Excel.Worksheet

    Dim ws As Excel.Worksheet
    Set ws = wb.Worksheets.Add
    ws.Name = sSheetName

    Dim rngBlock As Excel.Range
    Set rngBlock = ws.Range(ws.Cells(1, 1), ws.Cells(lRowsDeep, lColumnsWide))

    rngBlock.Formula = "=RANDBETWEEN(1,100000)"
    rngBlock.Value2 = rngBlock.Value2

    Set CreateSheetAndPopulateWithBlockOfData = ws
End Function

Answer 2

you could try this:

Sub SpliteIntoMultipleTab()
    Dim colNum As Long, iCol As Long
    With Worksheets("Sheet1").UsedRange
        colNum = .Columns.count
        Do
            Worksheets.Add(After:=Worksheets(Worksheets.count)).Range("A1:IT1").Resize(.Rows.count).Value = .Columns(iCol + 1).Resize(, 254).Value
            iCol = iCol + 254
            colNum = colNum - 254
        Loop While colNum > 0
    End With
End Sub

which copies values only and speed up things considerably