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

我有一个Excel文件，我填写了t恤的大小，名称和数字。 这里的目标是…一旦表格被填写完毕，我可以点击一个button，将所有的小块复制到一个新的表格，所有的介质，到另一个，等等。 我可以select整行，但我只想复制几个单元格。 我现在也把它们粘贴在新表单的同一行，就像它们在旧表单中一样。 我只是想让他们出现在下一个可用的线路上。 这里有些例子…

EXCEL表格（1）“MAIN”

BCD ----------------------------------------- **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 

（2）“小”是应该的

 BCD ----------------------------------------- **Name** | Size | # | ----------------------------------------- Joe Small 1 Ben Small 14 

（2）“小”是什么在发生

 BCD ----------------------------------------- **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 

对下一个尺寸…

在第一部分中，我select了整行，因为这是包含我想要在列B中的variables的行，但我不需要整行，我只需要select列B，但该行中的D。

现在我明白“matchRow”也是数据粘贴在同一行上的原因，但是我不知道如何使它进入下一个可用行。

Answer 1

有很多花里胡哨的替代方法。 考虑到你目前的经验水平，斯科特·克莱纳（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 

更新的代码，并validation它与提供的示例数据和原始数据一起工作：

 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 

Answer 2

命名表单的大小，并使用这个：

 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 

由于工作表被命名为大小，所以一行就足够了。 它只在所find的行上将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