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

Question

我有一个包含 3000 列的 Excel 工作表，我需要转换此工作表，使一个选项卡仅包含 254 列，其余的将转到下一个选项卡。所以我需要一个可以执行相同功能的 VBA 代码（宏）。

到目前为止，我只编写了以下代码，它创建了 3000 个选项卡，每个选项卡有一列，而且由于我没有为空白列设置任何条件，所以它也将进入无限循环。

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

使用整数除法和取模，例如取第 1000 列

1000 \ 254 = 3 

1000 mod 254 = 238 

给出第 3 页和第 238 列。

所以使用 \ 和 mod 从 1 循环到 3000。

您的代码非常不标准，我无法理解它，我建议您从我的代码开始，这是一个将数据块分成单独工作表的说明性示例。然后将代码复制到新工作簿中

只运行一次CreateSheetAndPopulateWithBlockOfData 以创建一个数据块。 运行 Test 运行 BreakBlockIntoChunks 例程，您可以试验块大小。

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

你可以试试这个：

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

它只复制值并大大加快速度