问题
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...
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" AS IT SHOULD BE
B C D
-----------------------------------------
**Name** | Size | # |
-----------------------------------------
Joe Small 1
Ben Small 14
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
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
ON TO THE NEXT SIZE...
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.
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.
回答1:
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 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
回答2:
Name the sheets the size and use this:
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
Since the sheet is named as the size, the one line is sufficient. It copies only B to D on the row found and puts it in the next available row on the sheet named as the size.
Note: This will not work if the sheets are not named the same as the size in column C on the main sheet.
One should also avoid using the .select whenever possible, as it will slow down the code.
EDIT: with this layout:
I change the code to:
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
来源：https://stackoverflow.com/questions/34621490/if-cell-value-is-specific-size-copy-3-cells-in-that-row-to-new-sheet