如果Cell.Value是特定大小，則將該行中的3個單元格復制到新表中

Question

我有一個Excel文檔，其中填寫了T恤的尺寸，名稱和數字。 此處的目標是...填寫表格后，我可以按一個按鈕，該按鈕將復制所有小物件並將它們放到新的紙上，所有介質上，再放入另一個，依此類推。 我可以選擇整行，但是我只想復制一些單元格。 此時，我還將它們粘貼到新工作表中與舊工作表中相同的行中。 我只希望它們顯示在下一個可用行中。 這里有些例子...

在EXCEL SHEET（1）“主要”中

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

在EXCEL SHEET（2）中應將“小”

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

在EXCEL SHEET（2）中“發生”

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列中使用的變量，但是我不需要整個行，我只需要選擇D列中的B列即可。

現在，我明白了“ matchRow”也是為什么數據要粘貼到從其復制的同一行上的原因，但是我也不知道如何使它轉到下一個可用行。

Answer 1

將紙張命名為尺寸並使用此尺寸：

Private Sub CommandButton1_Click()
with sheets("Main")
    For Each Cell In .Range("C2",.range("C" & .rows.count).end(xlup))
        .range(.cells(cell.row,2),.cells(cell.row,4)).copy sheets(cell.value).range("B" & sheets(cell.value).rows.count).end(xlup).offset(1)               
    next cell
End with
End sub

由於將圖紙命名為尺寸，因此一行就足夠了。 它僅在找到的行上將B復制到D，並將其放在圖紙上的下一個可用行（稱為尺寸）中。

注意：如果工作表的名稱與主工作表的C列中的大小不同，將無法使用此功能。

人們還應盡可能避免使用.select ，因為它會使代碼變慢。

編輯：使用此布局：

我將代碼更改為：

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

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