Search code examples
vbaexcelworksheet

If Cell.Value is specific size, Copy 3 cells in that row to new sheet


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.


Solution

  • 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