跨 2 个工作表复制和粘贴的搜索功能需要对粘贴的行数进行数量限制

Question

正如标题所说 - 此代码将搜索 Sheet1,Column I 中的某个词；例如 "White" 并将所有比赛粘贴到 sheet 上的集合行 2. 白色代表武术白带并将所有列为白带的学生姓名粘贴到集合行中 number/page在 sheet2 上，但是我只能在一页上放 30 个名字，有几个月有超过 30 个白带，所以我需要它将前 30 个名字粘贴到集合行中，其余的在下一页中比方说，从第 30 条白带向下 5 行。

有数百名学生和 23 个不同的腰带级别，它们总是在 sheet1 上更改行号，因此固定方法行不通。请帮忙。

Sub ADULTClearAndPaste()

Dim lr As Long, lr2 As Long, r As Long
Set Sh1 = ThisWorkbook.Worksheets("ADULT members to cut & past")
Set Sh2 = ThisWorkbook.Worksheets("ADULT Sign On Sheet")

Sh1.Select

lr = Sh1.Cells(Rows.Count, "B").End(xlUp).Row
w = 7
For r = 2 To lr
If Range("I" & r).Value = "White" Then
    Sh2.Cells(w, 5).Value = Sh1.Cells(r, 2).Value
    Sh2.Cells(w, 6).Value = Sh1.Cells(r, 3).Value
    w = w + 1
End If

Next r

py = 79

For r = 2 To lr
If Range("I" & r).Value = "Pro Yellow" Then
    Sh2.Cells(py, 5).Value = Sh1.Cells(r, 2).Value
    Sh2.Cells(py, 6).Value = Sh1.Cells(r, 3).Value
    py = py + 1
End If

Next r
Sh2.Select

End Sub

Answer 1

您可能会遇到一些问题。您将 w 和 py 定义为整数，但您说每个类别中可能有很多人，我假设这些数字会发生变化，因此您可能会因指定从哪一行开始而遇到问题。

这将允许您将 23 种腰带颜色作为数组放入（将腰带 (2) 更改为腰带 (23) 并填充颜色），然后它将格式化您的第二个 sheet根据第一页每种颜色的数量。

我假设您在前六行的第二个 sheet 上有一个 header。您可能需要更新 Header 变量以准确引用该范围，因为这将插入分页符，然后根据需要重复复制 header：

Sub ADULTClearAndPaste()
Dim Belts(2) As String
Belts(1) = "White"
Belts(2) = "Pro Yellow"

Dim NewRow As Long
Dim RowCounter As Long
Dim Item As Range
Dim Header As Range
Dim Sht1 As Worksheet
Dim Sht2 As Worksheet

Set Sht1 = ThisWorkbook.Worksheets("ADULT members to cut & past")
Set Sht2 = ThisWorkbook.Worksheets("ADULT Sign On Sheet")
'Specify Header Range
Set Header = Sht2.Range("A1:F6")

NewRow = 7
For i = 1 To UBound(Belts)
    'This creates a new header/page for the next belt color
    If NewRow <> 7 Then
        Sht2.Rows(NewRow).PageBreak = xlPageBreakManual
        Sht2.Range(Sht2.Cells((NewRow), 1), Sht2.Cells((NewRow + 5), 6)).Value = Header.Value
        NewRow = NewRow + 6
    End If

    'This will reference which color is being processed,
    'I put it in there for reference but I figured you would update it
    Sht2.Range("A" & NewRow).Value = Belts(i)
    RowCounter = 0

    For Each Item In Sht1.Range("I1:I" & Sht1.UsedRange.Rows.Count)

        If Item.Value = Belts(i) Then
            Sht2.Cells(NewRow, 5).Value = Item.Offset(0, 1).Value
            Sht2.Cells(NewRow, 6).Value = Item.Offset(0, 2).Value
            NewRow = NewRow + 1
            RowCounter = RowCounter + 1
            If RowCounter = 30 Then
                'When you hit 30 lines the counter resets and a new header is added
                Sht2.Rows(NewRow).PageBreak = xlPageBreakManual
                Sht2.Range(Sht2.Cells((NewRow), 1), Sht2.Cells((NewRow + 5), 6)).Value = Header.Value
                NewRow = NewRow + 6
                RowCounter = 0
            End If
        End If
    Next Item
Next i
Sht2.Select

End Sub

跨 2 个工作表复制和粘贴的搜索功能需要对粘贴的行数进行数量限制

Search function to copy and paste across 2 worksheets needs a number limit on amount of rows pasted

excel

vba

count

copy-paste

string-matching