我有一个包含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