☰

Excel：将 2 列范围 (A:B) 拆分为多个具有预设行数的小列

tag-icon • tag-icon microsoft-excel vba microsoft-excel-2016
Excel：将 2 列范围 (A:B) 拆分为多个具有预设行数的小列

我正在努力解决一个问题；我试图将两列（A 和 B）拆分成多个包含预设行数的列（例如每列 50 行），这两列需要保留在一起，其中包含 100 到 1,000 行信息。

我发现以下 VBA 代码有效，但它只能将 1 列拆分为多列，而不是 2 列。我尝试将两列合并为一列，使用下面的宏，然后使用文本到列再次拆分数据，但这需要太多手动工作。

有没有办法修改下面的代码，或者另一个可以提供所需结果的替代 VBA 代码或 Excel 函数。

非常感谢

    'Updateby20141106
    Dim rng As Range
    Dim InputRng As Range
    Dim OutRng As Range
    Dim xRow As Integer
    Dim xCol As Integer
    Dim xArr As Variant
    xTitleId     = "KutoolsforExcel"
    Set InputRng = Application.Selection
    Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type: = 8)
    xRow         = Application.InputBox("Rows :", xTitleId)
    Set OutRng   = Application.InputBox("Out put to (single cell):", xTitleId, Type: = 8)
    Set InputRng = InputRng.Columns(1)
    xCol         = InputRng.Cells.Count / xRow
    ReDim xArr(1 To xRow, 1 To xCol + 1)
    For i = 0 To InputRng.Cells.Count - 1
        xValue = InputRng.Cells(i + 1)
        iRow = i Mod xRow
        iCol = VBA.Int(i / xRow)
        xArr(iRow + 1, iCol + 1) = xValue
    Next
    OutRng.Resize(UBound(xArr, 1), UBound(xArr, 2)).Value = xArr
End Sub

预期目标将与此类似： A 列和 B 列被分成 4 列，每列 20 行。

答案1

欢迎！

将数据复制到其他单元格的代码本身非常简单，与八年前从宏中获取的代码没有太大区别（大小相同）。

与往常一样，当用户在对话框中指定计算数据时，代码的最大部分是组织对话框并检查数据输入的正确性：用户是否使用“取消”按钮关闭了输入框？他是否指示了整列中有近一百万个空单元格和无用单元格？他是否在源范围内指定了目标单元格？原始范围是否包含移动到其他位置时可能中断的公式？

Option Explicit
Sub suSplit()
Dim InputRng As Range, OutRng As Range, CopyRng As Range, aFormulas As Variant
Dim nRow As Long, nColumns As Long, nRows As Long
Dim xTitleId As String: xTitleId = "SuperUser for Excel"
    Set InputRng = Application.Intersect(Application.Selection, ActiveSheet.UsedRange)
    On Error Resume Next
        Set InputRng = Application.InputBox("Sourse Range:", xTitleId, InputRng.Address, Type:=8)
        Set InputRng = Application.Intersect(InputRng, ActiveSheet.UsedRange)
        If InputRng Is Nothing Then Exit Sub
        nColumns = InputRng.Columns.Count
        nRows = InputRng.Rows.Count
        nRow = Application.InputBox("Count of rows (new height):", xTitleId)
        If nRow < 1 Then Exit Sub
        If nRow >= nRows Then Exit Sub
        Set OutRng = Application.InputBox("Target Range (single top-left cell):", xTitleId, Type:=8)
        If OutRng Is Nothing Then Exit Sub
        If OutRng.Column + nColumns > ActiveSheet.Columns.Count Then Exit Sub
        If Not Application.Intersect(InputRng, OutRng) Is Nothing Then Exit Sub
    On Error GoTo 0
    aFormulas = InputRng.FormulaLocal
    InputRng.Value = InputRng.Value
    Set CopyRng = InputRng.Resize(nRow, nColumns)
    Do While CopyRng.Row <= nRows
        CopyRng.Copy Destination:=OutRng
        Set CopyRng = CopyRng.Offset(nRow, 0)
        If OutRng.Column + nColumns > ActiveSheet.Columns.Count Then Exit Do
        Set OutRng = OutRng.Offset(0, nColumns)
    Loop
    InputRng.FormulaLocal = aFormulas
End Sub

相关内容