有没有一个函数可以将重复的值拆分到Excel VBA的页面中？

qfe3c7zg 于 2023-01-14 发布在其他

关注(0)|答案(1)|浏览(120)

我想参照A列将Excel工作表中的行拆分成不同的工作表。例如，它会自动将A2：A5之间带有“A3FK”的行复制到newsheet2。将A6：A18之间带有“A4FK”的行复制到newsheet3。如下图所示。
我有一个代码，它按照我给定的行数划分页面。
如何编辑它以引用单元格值？

Sub CutAndPasteToNewPage()

  
Dim one,two As String

    Lines = InputBox("In how many lines: ", "Start", Default)
    First = ActiveSheet.Name
    LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
 
    For i = 1 To LastRow
        c = i + Lines
        CutArea = "A" + CStr(i) + ":" + "A" + CStr(c)
        ActiveSheet.Range(CutArea).Cut

        Sheets.Add After:=ActiveSheet
        ActiveSheet.Paste
        Application.CutCopyMode = False

        Worksheets(First).Activate
        i = i + Lines
        Next

End Sub

尝试将该页拆分为引用A列中数据的不同页

excel

来源：https://stackoverflow.com/questions/75071865/is-there-a-function-that-will-split-repeated-values-into-pages-with-excel-vba

1条答案

按热度按时间

lpwwtiir1#

这可以通过以下方式完成：

使用以下数据集：

我们可以将数据导入到一些数组中，构建一些工作表，然后将数据复制到其中。

Option Explicit

Sub SplitToSheets()
    
    Dim I As Long
    Dim X As Long
    Dim Y As Long
    Dim Yo As Long
    Dim lRow As Long
    Dim lCol As Long
    Dim Master As Worksheet
    Dim WS As Worksheet
    Dim RefList
    Dim Datalist
    Dim OutList
    
    ' > Working with "Master" Sheet
    Set Master = ThisWorkbook.Worksheets("Master")
    With Master
    
        ' > Identify how many sheets we need, the last row/column on _
            master sheet, import data into arrays, resize output array _
            larger than required.
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        lCol = .Range("ZZ1").End(xlToLeft).Column
        RefList = WorksheetFunction.Unique(.Range("A2:A" & lRow))
        Datalist = .Range("A1").Resize(lRow, lCol)
        ReDim OutList(1 To UBound(Datalist, 1), 1 To UBound(Datalist, 2))
        Yo = 1
        
        ' Cycle Through each Label / New Worksheet
        For I = 1 To UBound(RefList, 1)
            
            ' > Build New Worksheet
            Debug.Print RefList(I, 1)
            Set WS = Worksheets.Add(, Master)
            WS.Name = RefList(I, 1)

            ' > Transfer all related data to array
            For Y = 1 To UBound(Datalist, 1)
                If Datalist(Y, 1) = RefList(I, 1) Or Y = 1 Then
                    For X = 1 To UBound(Datalist, 2)
                        OutList(Yo, X) = Datalist(Y, X)
                    Next X
                    Yo = Yo + 1
                End If
            Next Y

            ' > Output Array to New Worksheet
            WS.Range("A1").Resize(UBound(OutList, 1), _
                UBound(OutList, 2)).Value = OutList

            ' > Erase / Reset Array
            For Y = 1 To UBound(OutList, 1)
                For X = 1 To UBound(OutList, 2)
                    OutList(Y, X) = ""
                Next X
            Next Y
            Yo = 1

        Next I
        
    End With
    
End Sub

它的工作速度惊人地快，为我们提供了每个标签在足够的工作表之间分割的完整数据集：

工作表：