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

Question

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

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

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

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

Answer 1

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

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

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

空单元格被

找到

 IsEmpty( Cells(3,9) )

要打开现有工作表，请使用

Sheets("All").Select

所以

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

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

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

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

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

emptyRows = emptyRows + 1

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

If emptyRows > emptyRowsToStopAt
    rowInServiceSheet = currentRow  

代码开始...

dim emptyRowsToStop
dim emptyRows
For currentRow = 1 To 1000 

编辑：

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

这里是：

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