Question

我有一份excel文件，我填写了T恤尺码，名称和数字。这里的目标是......一旦表格填写完毕，我就可以点击一个按钮，复制所有小图片并将它们放到新的图纸上，所有介质上，再放到另一张图片上，依此类推。我可以选择整行，但我只想复制几个单元格。此时我也将它们粘贴到新纸张上的同一行中，就像它们在旧纸张中一样。我只是希望它们显示在下一个可用的行上。以下是一些例子......

在EXCEL SHEET（1）＆＃34; MAIN＆＃34;

B                  C               D
-----------------------------------------
**Name**         | Size          | #    |
-----------------------------------------
Joe                Small           1              There are other
Sarah              X-Small         3              instructions over
Peter              Large           6              here on this side
Sam                Medium          12             of the document
Ben                Small           14             that are important
Rick               Large           26

EX EXELEL SHEET（2）＆＃34; SMALL＆＃34;因为它应该

B                  C               D
-----------------------------------------
**Name**         | Size          | #    |
-----------------------------------------
Joe                Small           1
Ben                Small           14

EX EXELEL SHEET（2）＆＃34; SMALL＆＃34;发生了什么

B                  C               D
-----------------------------------------
**Name**         | Size          | #    |
-----------------------------------------
Joe                Small           1              There are other



Ben                Small           14             that are important

这是我的VBA代码，所以

Private Sub CommandButton1_Click()
For Each Cell In Sheets(1).Range("B:B")
    If Cell.Value = "Small" Then
        matchRow = Cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy

        Sheets("Small").Select
        ActiveSheet.Rows(matchRow).Select
        ActiveSheet.Paste
        Sheets("Main").Select
    End If
Next

接下来的尺寸......

在第一部分中，我选择整行，因为这是包含我想要在B列中的变量的行，但我不需要整行，我只需要选择B列D在那一排。

现在我理解＆＃34; matchRow＆＃34;这也是数据粘贴在同一行上的原因，但是我不确定如何将它转到下一个可用行。

Answer 1

将工作表命名为大小并使用：

.select

由于工作表被命名为大小，因此一行就足够了。它仅在找到的行上复制B到D，并将其放在名为大小的工作表上的下一个可用行中。

注意：如果工作表的名称与主工作表中C列的大小不同，则不起作用。

还应该尽可能避免使用Private Sub CommandButton1_Click() Dim mws As Worksheet Dim tws As Worksheet Set mws = Sheets("Main") With mws For Each cell In .Range("B3", .Range("B" & .Rows.Count).End(xlUp)) If Not SheetExists(cell.Value) Then Set tws = ActiveWorkbook.Sheets.Add tws.Name = cell.Value .Range("A2:D2").Copy tws.Range("A1") Else Set tws = Sheets(cell.Value) End If .Range(.Cells(cell.Row, 1), .Cells(cell.Row, 4)).Copy tws.Range("A" & tws.Rows.Count).End(xlUp).Offset(1) tws.Columns("A:D").AutoFit Next cell End With End Sub Function SheetExists(SName As String, _ Optional ByVal WB As Workbook) As Boolean On Error Resume Next If WB Is Nothing Then Set WB = ActiveWorkbook SheetExists = CBool(Len(WB.Sheets(SName).Name)) End Function，因为这会降低代码的速度。

编辑：使用此布局：

我将代码更改为：

{{1}}

Answer 2

备选方法，有很多铃声和口哨声。考虑到您目前的经验水平，Scott Craner的答案可能会更加实用，但对于任何寻求更高级方法的人来说都是如此：

编辑在评论中，OP提供了样本数据：

_____B_____  __C__  _D_
Name         Size     #
Joe 1-Youth  Small    2
Ben 1-Youth  Small    7
Bob 1-Youth  Small   10
Joe 1-Youth  Small   13
Joe 1-Youth  Small   22
Joe 1-Youth  Small   32
Joe 1-Youth  Small   99
Joe 1-Youth  Small    1
Joe 1-Youth  Small    3
Joe 3-Youth  Large    6
Joe 3-Youth  Large   11
Joe 3-Youth  Large   21

更新了代码并验证了它与提供的样本数据和原始数据一起使用：

Sub tgr()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsMain As Worksheet
    Dim rCopy As Range
    Dim rUnqSizes As Range
    Dim SizeCell As Range
    Dim sName As String
    Dim lAnswer As Long
    Dim i As Long

    Set wb = ActiveWorkbook
    Set wsMain = wb.Sheets("Main")

    lAnswer = MsgBox(Title:="Run Preference", _
                     Prompt:="Click YES to override existing data." & _
                     Chr(10) & "Click NO to append data to bottom of sheets." & _
                     Chr(10) & "Click CANCEL to quit macro and do nothing.", _
                     Buttons:=vbYesNoCancel)

    If lAnswer = vbCancel Then Exit Sub

    With wsMain.Range("C1", wsMain.Cells(Rows.Count, "C").End(xlUp))
        If .Parent.FilterMode Then .Parent.ShowAllData
        On Error Resume Next
        .AdvancedFilter xlFilterInPlace, , , True
        Set rUnqSizes = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If rUnqSizes Is Nothing Then
            MsgBox "No Data found in column C", , "No Data"
            Exit Sub
        End If
        If .Parent.FilterMode Then .Parent.ShowAllData

        For Each SizeCell In rUnqSizes
            sName = SizeCell.Value
            For i = 1 To 7
                sName = Replace(sName, ":\/?*[]", " ")
            Next i
            sName = WorksheetFunction.Trim(Left(sName, 31))
            If Not Evaluate("ISREF('" & sName & "'!A1)") Then
                wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = sName
                Set ws = wb.Sheets(sName)
                wsMain.Range("B1:D1").Copy
                ws.Range("B1").PasteSpecial xlPasteAll
                ws.Range("B1").PasteSpecial xlPasteColumnWidths
                Application.CutCopyMode = False
            Else
                Set ws = wb.Sheets(sName)
            End If
            .AutoFilter 1, SizeCell.Value
            Set rCopy = Intersect(wsMain.Range("B:D"), .Offset(1).Resize(.Rows.Count - 1).EntireRow)
            If lAnswer = vbNo Then
                rCopy.Copy ws.Cells(Rows.Count, "B").End(xlUp).Offset(1)
            Else
                ws.Range("B2:D" & Rows.Count).Clear
                rCopy.Copy ws.Range("B2")
            End If
        Next SizeCell
        If .Parent.FilterMode Then .Parent.ShowAllData
    End With

End Sub

如果Cell.Value是特定大小，请将该行中的3个单元格复制到新工作表

2 个答案: