Copy a partial row of data from one sheet to a new sheet within the same workbook based on cell content

问题

I have scoured the web for a solution to this challenge that I am having, but have not found a suitable solution. I have decent with formulas, but have no experience in VBA or other programming within Excel. I am hoping that one of the many Excel gurus can help me solve this challenge.

Sample Sheet https://dl.dropboxusercontent.com/u/95272767/Sample%20Sheet.xlsx

The rows of data always begin in row 4 and can extend down to row 1000.

I have a sheet of data (Linked Above) that was produced by underlying formulas. My goal is to copy partial rows of data based on the content of column F of the same row, while leaving both the formula and original data intact. Rows above 4 and column O need to remain on the original sheet.

For example...

Row 4 has in column F, ab1. The following cells A4 through N4 need to be copied to sheet labeled Client 1.

Row 5 has in column F, ab1. The following cells A5 through N5 need to be copied to sheet labeled Client 1.

Row 5 has in column F, ab2. The following cells A6 through N6 need to be copied to sheet labeled Client 2.

This process continues through to the end of the data.

Thanks so much in advance for any assistance that can be provided.

Cheers Scott

回答1:

Something like this should get you started. I have tried to comment it pretty thoroughly so as to explain what is happening in the macro:

Sub CopySomeCells()
Dim targetSheet As Worksheet 'destination for the copied cells'
Dim sourceSheet As Worksheet 'source of data worksheet'
Dim rng As Range 'range variable for all data'
Dim rngToCopy As Range 'range to copy'
Dim r As Long 'row counter'
Dim x As Long 'row finder'
Dim clientCode As String
Dim clientSheet As String

Set sourceSheet = Worksheets("Sheet1") '## The source data worksheet, modify as needed ##
    With sourceSheet
        '## the sheet may have data between rows 4 and 1000, modify as needed ##'
        Set rng = .Range("A4", Range("A1000").End(xlUp))

        '## iterate over the rows in the range we defined above ##'
        For r = 1 To rng.Rows.Count


            '## Set the range to copy ##'
            Set rngToCopy = Range(rng.Cells(r, 1), rng.Cells(r, 12))

            '## ignore rows that don't have a value in column F ##
            If Not rng.Cells(r, 6).Value = vbNullString Then

                '## Set the targetSheet dynamically, based on the code in column F ##'
                '  e.g., "ab1" --> Client 1, "ab2" --> Client 2, etc. '
                '## Set the client code ##"
                clientCode = rng.Cells(r, 6).Value

                '## determine what sheet to use ##'
                ' I do this by finding the client code in the lookup table, which
                ' is in range "O24:O37", using the MATCH function.
                ' Then, offset it -1 rows (the row above) which will tell us "Client Code 1", etc.

                clientSheet = .Range("O23").Offset( _
                    Application.Match(clientCode, .Range("O24:O37"), False), 0).Offset(-1, 0).Value
                ' take that value "Client Code 1" and replace "Code " with nothing, so that
                ' will then give us the sheet name, e.g., "Client Code 1" --> "Client 1", etc. ##'
                clientSheet = Replace(clientSheet, "Code ", vbNullString)

                Set targetSheet = Worksheets(clientSheet)

                '## Find the next empty row in this worksheet ##'
                x = Application.WorksheetFunction.CountA(targetSheet.Range("A:A")) + 1

                '## Copy the selected sub-range, ##'

                rngToCopy.Copy 

                '## Paste values only to the target sheet ##'
                targetSheet.Cells(x, 1).PasteSpecial Paste:=xlPasteValues, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            End If

        Next '## proceed to process the next row in this range ##'

    End With

End Sub

来源：https://stackoverflow.com/questions/16453447/copy-a-partial-row-of-data-from-one-sheet-to-a-new-sheet-within-the-same-workboo