如果 Cell.Value 是特定大小，则将该行中的 3 个单元格复制到新的 sheet
If Cell.Value is specific size, Copy 3 cells in that row to new sheet
我有一份 excel 文件，其中填写了 T 恤尺码、姓名和号码。这里的目标是...填写完表格后，我可以点击一个按钮，复制所有小件并将它们放到新的 sheet 上，所有介质上，放到另一个上，依此类推。我可以 select 整行，但我只想复制几个单元格。此时，我还将它们粘贴到新 sheet 中的同一行中，就像它们在旧 sheet 中一样。我只希望它们出现在下一个可用的行中。这里有一些例子...
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
IN EXCEL SHEET(2) "SMALL" 应该是
B C D
-----------------------------------------
**Name** | Size | # |
-----------------------------------------
Joe Small 1
Ben Small 14
在 EXCEL SHEET(2) "SMALL" 发生了什么
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
下一个尺码...
在第一部分，我 select 整行因为那是包含我想要在 B 列中的变量的行，但我不需要整行，我只需要select B 列到该行的 D 列。
现在我明白了 "matchRow" 也是为什么数据粘贴在复制时复制的同一行的原因，但我也不确定如何将其转到下一个可用行。
命名 sheet 大小并使用：
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
由于sheet被命名为大小，一行就足够了。它仅将找到的行上的 B 复制到 D，并将其放入名为大小的 sheet 上的下一个可用行中。
注意：如果 sheet 的名称与主 sheet 上 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
有很多附加功能的替代方法。考虑到您当前的经验水平，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
我有一份 excel 文件，其中填写了 T 恤尺码、姓名和号码。这里的目标是...填写完表格后，我可以点击一个按钮，复制所有小件并将它们放到新的 sheet 上，所有介质上，放到另一个上，依此类推。我可以 select 整行，但我只想复制几个单元格。此时，我还将它们粘贴到新 sheet 中的同一行中，就像它们在旧 sheet 中一样。我只希望它们出现在下一个可用的行中。这里有一些例子...
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
IN EXCEL SHEET(2) "SMALL" 应该是
B C D
-----------------------------------------
**Name** | Size | # |
-----------------------------------------
Joe Small 1
Ben Small 14
在 EXCEL SHEET(2) "SMALL" 发生了什么
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
下一个尺码...
在第一部分，我 select 整行因为那是包含我想要在 B 列中的变量的行，但我不需要整行，我只需要select B 列到该行的 D 列。
现在我明白了 "matchRow" 也是为什么数据粘贴在复制时复制的同一行的原因，但我也不确定如何将其转到下一个可用行。
命名 sheet 大小并使用：
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
由于sheet被命名为大小，一行就足够了。它仅将找到的行上的 B 复制到 D，并将其放入名为大小的 sheet 上的下一个可用行中。
注意：如果 sheet 的名称与主 sheet 上 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
有很多附加功能的替代方法。考虑到您当前的经验水平，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