vba 根据列中的条件复制一系列行，然后粘贴到名为条件的不同工作表中

Copy a range of rows depending on criteria in a column and paste into a different sheet named as the criteria

提问by user1443067

I need some help with VBA in Excel 2010 to write a macro.

我需要一些有关 Excel 2010 中 VBA 的帮助来编写宏。

I need to know how to copy a specific range of rows depending on the criteria in one column and paste every row (entire row, all other fields too) containing that specified criteria into its corresponding sheet (explained more below). The hard part is that those "destination" sheets might already have some data that needs to STAY there and NOT be deleted. So, how can I write a macro to do what I just described, but when it goes to paste, it finds the first empty row to begin pasting?

我需要知道如何根据一列中的条件复制特定范围的行并将包含该指定条件的每一行（整行，所有其他字段）粘贴到其相应的工作表中（在下面详细解释）。困难的部分是那些“目标”工作表可能已经有一些数据需要留在那里而不是被删除。那么，如何编写一个宏来执行我刚刚描述的操作，但是当它进行粘贴时，它会找到第一个空行开始粘贴？

I have one workbook with about 5 sheets. The first sheet is the ALLsheet that contains all of the data. The next 4 sheets are named Tree, Graffiti, Lightand Pothole. All of the fields are the same across all 5 sheets. In every sheet, there is one field called Type Of Servicewhich is one of those four services (tree, graffiti, lightor pothole).

我有一本大约有 5 张纸的工作簿。第一个工作表是ALL包含所有数据的工作表。接下来的4张被命名为Tree，Graffiti，Light和Pothole。所有 5 个工作表中的所有字段都相同。在每张工作表中，有一个字段称为Type Of Service这四种服务之一（tree、graffiti、light或pothole）。

What I need to do is filter the ALLsheet for each of those 4 services (one at a time), select all of the fields and all of the rows that contain the specified service, copy it all and then paste it into its individual sheet. Those individual sheets may contain some data, so the paste needs to find the first empty row, and paste it there. Concatenate the sheet as it is with the copied rows from the ALL sheet. I need the macro to do all 4 service filters/pastes together.

我需要做的是ALL为这 4 个服务中的每一个过滤工作表（一次一个），选择包含指定服务的所有字段和所有行，将其全部复制，然后将其粘贴到其单独的工作表中。这些单独的工作表可能包含一些数据，因此粘贴需要找到第一个空行，并将其粘贴到那里。将工作表与从 ALL 工作表中复制的行连接起来。我需要宏来将所有 4 个服务过滤器/粘贴在一起。

回答by pashute

you get to understand everything by recording a macro and looking at it. There's one extra peace of knowledge and that is instead of saying "A1:G3" you can use Range( Cells(x,y), Cells(x,y) ) and do for example

您可以通过录制宏并查看它来了解所有内容。还有一个额外的知识和平，那就是说“A1：G3”，你可以使用 Range( Cells(x,y), Cells(x,y) ) 并做例如

Range( Cells(1,1), Cells(1,3).Select
ActiveSelection.Copy ' or .Cut 

Go to Excel Options and on the GENERAL tab select USE R1C1 Style. The excel shows numbers on the columns too.

转到 Excel 选项并在常规选项卡上选择使用 R1C1 样式。excel也在列上显示数字。

Empty cells are found by

空单元格被发现

 IsEmpty( Cells(3,9) )

For opening an existing sheet use

用于打开现有工作表使用

Sheets("All").Select

So

所以

dim currentService
currentService = Cells(i, 3) ' current row, 13'th column
Sheets(currentService).Select

So it goes like this: Either find the filter function and then iterate through the cells by moveDown.

所以它是这样的：要么找到过滤器函数，然后通过 moveDown 遍历单元格。

probably the easiest would be to sort by service find start and end row of each service by iterating on line till reach something else (that's not empty) copy the whole range for each service select the correct book for that service, find the empty line on that service sheet (by reading a cell on each row, or if you want to check a few cells:

可能最简单的方法是按服务排序，通过在线迭代找到每个服务的开始和结束行，直到到达其他东西（不是空的）复制每个服务的整个范围为该服务选择正确的书，找到空行该服务表（通过读取每行的一个单元格，或者如果您想检查几个单元格：

  Function hasRowContent (rownum as Integer) as Boolean
      Dim rowContentCheck
      rowContentCheck = Cells(rownnum, 1) & Cells(rownum, 3) & Cells(rownnum, 7)
      hasRowContent = rowContentCheck <> "" 
      Return
  End Function

Count the number of empty rows. Each row you encounter without content increase the emptyRows counter

计算空行数。您遇到没有内容的每一行都会增加 emptyRows 计数器

emptyRows = emptyRows + 1

Each row you encounter with content, set the emptyRows back to zero and start counting from here.

您遇到内容的每一行，将 emptyRows 设置回零并从这里开始计数。

If emptyRows > emptyRowsToStopAt
    rowInServiceSheet = currentRow  

Beginning of code...

代码开头...

dim emptyRowsToStop
dim emptyRows
For currentRow = 1 To 1000 

EDIT:

编辑：

All code explained in my first answer

在我的第一个答案中解释了所有代码

Here goes:

开始：

Public Function SheetExists(sheetName As String) As Boolean
' Sheet! It Exists

Dim wrkSheet As Worksheet

SheetExists = False
For Each wrkSheet In ThisWorkbook.Worksheets
    If wrkSheet.Name = sheetName Then
        SheetExists = True
        Exit For
    End If
Next

End Function

Sub createMissingServicePages()
' start on first cell in ALL
Sheets("all").Select
Row1.Select
Row1.Copy

Dim serviceTypes
serviceTypes = Array("Tree", "Graffiti", "Light", "Pothole")
Dim serviceTypeName As String

For Each serviceType In serviceTypes
    serviceTypeName = serviceType

    If Not SheetExists(serviceTypeName) Then
        ' create a new sheet - at the end of the Sheets list
        Sheets.Add After:=Sheets(Sheets.Count) ' after 8
        ' and name it
        Sheets(Sheets.Count).Name = serviceTypeName ' by now its 9

        ' select it and copy first row to it
        '.. copy header row
        Sheets("All").Select
        Rows(1).Select
        Rows(1).Copy

        ' .. paste in target sheet
        Sheets(Sheets.Count).Select
        Cells(1, 1).Select
        ActiveCell.PasteSpecial xlPasteAll
    End If
Next

End Sub

Sub updateServicePages()
' if you wish to see the column numbers rather than letters
' change settings in Options / GENERAL tab to View R1C1 style

Call createMissingServicePages

' start on first cell in ALL
Sheets("all").Select
Cells(1, 1).Select

' We'll need this later:
' count the columns
Dim columnsCount As Integer
For Each aCell In Rows(1).Cells
    If IsEmpty(aCell) Then
        columnsCount = aCell.Cells.Column
        Exit For
    End If
Next


' get TypeOfService column number
Dim serviceTypeHeaderText As String
Dim serviceTypeColumnnum As Integer

serviceTypeHeaderText = "type of service" ' ignoring case...

Cells.Find(What:=serviceTypeHeaderText, _
           After:=ActiveCell, _
           LookIn:=xlFormulas, LookAt:=xlPart, _
           SearchOrder:=xlByRows, SearchDirection:=xlNext, _
           MatchCase:=False, SearchFormat:=False).Activate
serviceTypeColumnnum = ActiveCell.Column

' sort the whole range
Cells.Select ' first select the whole range
' unremark next line of code if you want to format the data nicely...
'Cells.EntireColumn.AutoFit ' if we are already at it
Selection.Sort Key1:=Cells(1, serviceTypeColumnnum), _
               Order1:=xlAscending, Header:=xlYes, _
               OrderCustom:=1, MatchCase:=False, _
               Orientation:=xlTopToBottom, _
               DataOption1:=xlSortNormal


' now move the data for each typeofService
Dim serviceTypes
Dim serviceTypeName As String
serviceTypes = Array("Tree", "Graffiti", "Light", "Pothole")
Dim rangeStart As Integer
Dim rangeEnd As Integer
For Each serviceType In serviceTypes
'   we reset for each serviceType
    Sheets("all").Select
    Cells(1, 1).Select

    rangeStart = 0
    rangeEnd = 0
    serviceTypeName = serviceType

    ' .. find range start and end
    For Each aRow In Rows
        If aRow.Cells(serviceTypeColumnnum) = serviceTypeName Then
            If rangeStart = 0 Then rangeStart = aRow.Cells.Row
        Else
            If rangeStart <> 0 Then ' we just exited the range
                rangeEnd = aRow.Cells.Row - 1
                Exit For ' done with this serviceType range
            Else ' didn't reach our range yet

            End If
        End If
    Next ' row

    ' No 'continue' in VBA... and don't want to use a GOTO
    ' If rangeStart = 0 Or rangeEnd = 0 Then 'continue for

    If rangeStart <> 0 And rangeEnd <> 0 Then

        ' .. now copy serviceType to correct sheet
        Dim servicetypeRange As Range
        Set servicetypeRange = Range(Cells(rangeStart, 1), Cells(rangeEnd, columnsCount))
        servicetypeRange.Select
        servicetypeRange.Copy
        ' find empty row in target sheet
        Sheets(serviceTypeName).Select
        Dim emptyrowNum As Integer
        Dim emptyrowCount As Integer
        Dim emptyrowMax As Integer
        Dim emptyrowMargin
        emptyrowMax = 5 ' set this to 1 if there are no spaces in the data
        emptyrowMargin = 0 ' change this if you want an empty row between last data and new data
        For Each aRow In Rows
           If IsEmpty(aRow.Cells(1)) Then ' you could check over a few cells by: & isEmpty(aRow.Cells(2)) etc.
                emptyrowCount = emptyrowCount + 1
                If emptyrowCount > emptyrowMax Then
                    emptyrowNum = aRow.Row - emptyrowCount ' last empty row
                    If emptyrowNum < 1 Then emptyrowNum = 1
                    emptyrowNum = emptyrowNum + emptyrowMargin
                    Exit For ' we found empty row
                End If
            End If
        Next
        Cells(emptyrowNum, 1).Select
        ActiveCell.PasteSpecial xlPasteAll ' ,skipBlanks if needed
    End If
Next ' serviceType

Sheets("All").Select
Cells(1, 1).Select
MsgBox "Done!"
End Sub