Question

我已经在网上搜索了我遇到的这个挑战的解决方案，但还没有找到合适的解决方案。我有很好的公式，但没有经验的VBA或Excel中的其他编程。我希望众多Excel专家中的一位可以帮助我解决这一挑战。

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

数据行总是从第4行开始，可以向下延伸到第1000行。

我有一张由基础公式生成的数据表（Linked Above）。我的目标是根据同一行的F列内容复制部分数据行，同时保留公式和原始数据的完整性。高于4和O列的行需要保留在原始工作表上。

例如......

第4行在F列中，ab1。需要将以下单元格A4到N4复制到标记为客户端1的图纸上。

第5行在F列中，ab1。需要将以下单元格A5到N5复制到标记为客户端1的工作表中。

第5行在F列中，ab2。需要将以下单元格A6到N6复制到标有客户端2的工作表。

此过程一直持续到数据结束。

非常感谢您提供任何可以提供的帮助。

干杯斯科特

Answer 1

这样的事情应该让你开始。我试图对它进行彻底的评论，以便解释宏中发生的事情：

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

根据单元格内容将部分数据行从一个工作表复制到同一工作簿中的新工作表

1 个答案: