VBA宏:如果数据与通配符匹配,则将其复制到特定的工作表

时间:2018-08-22 03:55:21

标签: excel excel-vba

我有一个包含1000多个行的电子表格。试图将“ H”列之一中匹配的数据复制到工作表中,该工作表也使用H的名称。但是还希望对数据进行排序,以使“ H”列中的值与“ comp-harb”匹配; “ comp-harb-active”; comp-harb-exp”全部复制到单个标记为“ comp-harb”的工作表中。我能够查找答案以找到可以使用的代码。但是它将“ comp *”分离为单独的工作表。有没有一种方法可以指定将它们复制到一个工作表中?非常感谢您的帮助。

    Option Explicit

Sub CopyRows()

Dim rngMyRange As Range, rngCell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim SheetName As String
Dim Cell As Range
Dim bk As Workbook

Set bk = Application.ActiveWorkbook

Application.ScreenUpdating = False

With Sheets("combined")
Set rngMyRange = .Range(.Range("H2"), .Range("H65536").End(xlUp))

    For Each rngCell In rngMyRange
        rngCell.EntireRow.Select

        Selection.Copy

If rngCell Like "comp-harb*"  Then GoTo Line1 Else GoTo Line2
Line1:
      If WorksheetExists("comp-harb") Then
            SheetName = "comp-harb"
            Sheets(SheetName).Select
            Set sht = ActiveWorkbook.Worksheets(SheetName)
            LastRow = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row
            Rows(LastRow + 1).Select
            Selection.Insert Shift:=xlDown
           Else: Sheets.Add After:=ActiveSheet
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            ActiveSheet.Name = "comp-harb"
           GoTo Lastline


      End If
Line2:
 If WorksheetExists(rngCell.Value) Then
            SheetName = rngCell.Value
            Sheets(SheetName).Select
            Set sht = ActiveWorkbook.Worksheets(SheetName)
            LastRow = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row
            Rows(LastRow + 1).Select
            Selection.Insert Shift:=xlDown
 Else: Sheets.Add After:=ActiveSheet
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            ActiveSheet.Name = rngCell.Value

        End If
GoTo Lastline




        'Go back to the DATA sheet
Lastline:
        Sheets("combined").Select
    Next

End With

End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!H1)")
End Function

0 个答案:

没有答案