如果 Cell.Value 是特定大小，则将该行中的 3 个单元格复制到新工作表 [英] If Cell.Value is specific size, Copy 3 cells in that row to new sheet
问题描述
我有一个 excel 文档，我在其中填写了 T 恤的尺寸、名称和编号.这里的目标是......一旦表格填写完毕，我可以点击一个按钮，将所有的小文件复制到一张新纸上，所有的媒体上，到另一个，等等.我可以选择整行，但我只想复制几个单元格.此时，我还将它们粘贴到新工作表上的同一行中，就像它们在旧工作表中一样.我只希望它们出现在下一个可用的行上.以下是一些示例...
I have an excel document that I fill out with tshirt sizes, names, and numbers. The goal here is... once the form is filled out, I can hit a button that will copy all the smalls and put them onto a new sheet, all the mediums, onto another, and so on. I CAN select the whole row, but I ONLY WANT to copy a few cells. I am also pasting them at this point into the same row on the new sheet as they were in the old sheet. I just want them to show up on the next available line. Here are some examples...
在 EXCEL 工作表 (1) 中主要"
IN EXCEL SHEET(1) "MAIN"
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 工作表中 (2) 应该是小"
IN EXCEL SHEET(2) "SMALL" AS IT SHOULD BE
B C D
-----------------------------------------
**Name** | Size | # |
-----------------------------------------
Joe Small 1
Ben Small 14
在 EXCEL Sheet(2) 中小"发生了什么
IN EXCEL SHEET(2) "SMALL" WHAT IS HAPPENING
B C D
-----------------------------------------
**Name** | Size | # |
-----------------------------------------
Joe Small 1 There are other
Ben Small 14 that are important
到目前为止，这是我的 VBA 代码
HERE IS MY VBA CODE SO FAR
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 列那一行.
In the first part, I am selecting the entire row because that is the row that contains the variable that I want in Column B, but I don't need the entire row, I only need to select Column B though D in that row.
现在我明白了matchRow"也是数据粘贴在复制的同一行的原因，但我不知道如何让它转到下一个可用的行.
Now I understand "matchRow" is also why the data is pasting on the same row as it was copied from, but I'm not sure how to make it go to next available line either.
推荐答案
有很多花里胡哨的替代方法.考虑到您目前的经验水平，Scott Craner 的答案可能更实用，但对于任何寻求更高级方法的人来说:
Alternate method with lots of bells and whistles. Scott Craner's answer is likely far more practical considering your current experience level, but for anybody looking for a more advanced approach:
EDIT 在评论中，OP 提供了示例数据:
EDIT In comments, OP provided sample data:
_____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
更新代码并验证它适用于提供的示例数据和原始数据:
Updated code and verified it works with the provided sample data and the original data:
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 个单元格复制到新工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
