vba Excel 2007，根据 1 列中的值将行从一张工作表复制到另一张工作表

Excel 2007, Copying rows from one sheet to another based on a value in 1 column

提问by SteveW1968

I'm trying to copy a range of rows where the rows chosen are based on the value in one cell.I want to do this for all rows containing the same value in a cell, then move on to the next value an append to the bottom of the first list.

我正在尝试复制一系列行，其中选择的行基于一个单元格中的值。我想对单元格中包含相同值的所有行执行此操作，然后移至下一个值并附加到第一个列表的底部。

Below is my attempt at explaining what I wish to achieve - hopefully the above will help explain more my dilemma. I have looked around for this but not quite found what I want. I thought it would be simple and probably is.

以下是我试图解释我希望实现的目标 - 希望以上内容有助于更多地解释我的困境。我已经环顾四周，但还没有完全找到我想要的。我认为这很简单，可能是。

I receive a data dump with thousands of rows of data and 18 columns. Based on the value of column P "Contract" I want to copy entire rows into a new single worksheet workingdata. Not all the data will go into the workingdataworksheet.

我收到一个包含数千行数据和 18 列的数据转储。根据列 P "Contract" 的值，我想将整行复制到一个新的单个工作表中workingdata。并非所有数据都会进入workingdata工作表。

The contract numbers are c1234, c1235, c2345 etc.

合同号为 c1234、c1235、c2345 等。

What i am after achieving is copying and sorting, so copy all the rows of data where contract number is c1234, in workingdata, then directly below it copy all rows where contract is c1235 and so on.

我实现后是复制和排序，所以复制合同编号为c1234的所有数据行，在workingdata，然后直接在其下方复制合同为c1235的所有行，依此类推。

I thought I could select the range P:P and sort but to no avail.

我以为我可以选择范围 P:P 并排序但无济于事。

Sheets("Data Dump").Select
Columns("P:P").Select
If Selection.Value = "C1234" Then
Selection.EntireRow.copy

I know I should post what i have tried, but it would be a pathetic, for some reason I just can't seem to get my head round this one.

我知道我应该发布我尝试过的内容，但这会很可悲，出于某种原因，我似乎无法理解这个问题。

Here's my latest effort - I know there are errors

这是我最近的努力 - 我知道有错误

Dim oWorksheet As Excel.Worksheet
Dim oRangeSource As Excel.Range
Dim oRangeDest As Excel.Range

Set oWorksheet = Worksheets("DataDump")
Set oRangeSource = oWorksheet.Range("p:p")
Set oRangeDest = Worksheets("workingdata")

If oRangeSource="CA0004000" Then Select.EntireRow

Selection.EntireRow.copy
Sheets("workingdata").Select.Paste
End If

latest effort but does not sort data or get rid of unwanted, I have to do a manual filter and sort which sorts of defeats the object of the macro

最新的努力，但没有对数据进行排序或摆脱不需要的，我必须做一个手动过滤器并排序哪种类型的宏的对象失败

Sub copy()
'
' copy Macro
'
Dim rngContracts As Range:      Set rngContracts = Sheets("DataDump").Range("P:P")
Dim wsData As Worksheet

Dim wsFound As Boolean: wsFound = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
    If ws.Name = "Working Data" Then
        Set wsData = ws
        wsFound = True
        Exit For
    End If
Next ws

If wsFound = False Then
    Application.CutCopyMode = False
    ActiveSheet.Range("A1").EntireRow.copy
    Set wsData = Sheets.Add(After:=Sheets(Sheets.Count))
    wsData.Name = "Working Data"
    wsData.Range("A1").EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If

Dim iCell As Range
For Each iCell In rngContracts
    If iCell.EntireRow.Hidden = False Then
        Application.CutCopyMode = False
        iCell.EntireRow.copy
        wsData.Range("P" & Rows.Count).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteAll, Transpose:=False
    End If
Next iCell

Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Latest attaempt - copies the data I need but does not sort:

最新尝试 - 复制我需要但不排序的数据：

Sub copytest()
'
' copytest Macro
'
Set MR = Sheets("data Dump").Range("P:P")

    For Each cell In MR

If cell.Value = "CA000154" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial

    End If

If cell.Value = "CA000220" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If
If cell.Value = "CA000393" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If
If cell.Value = "CA000429" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    End If
Application.CutCopyMode = False

Next

End Sub

回答by nightcrawler23

Record a macro to set filters on your data select one filter only.

录制宏以在数据上设置过滤器，仅选择一个过滤器。

Then, edit the code and loop through each filter copying the visible range on to your sheet. This must also sort your data as the filters are already sorted.

然后，编辑代码并循环遍历每个过滤器，将可见范围复制到您的工作表上。这也必须对您的数据进行排序，因为过滤器已经排序。

Also, take a look at creating filter arrays in the Excel VBA help with regards to using them to sort.

此外，请查看 Excel VBA 帮助中有关使用它们进行排序的创建过滤器数组。