VBA 搜索字符串并复制行

Question

我从一个表格开始，其中包含一个名称，该名称对应于工作代码和所述工作的开始日期。 见下文：

预期的结果是几乎翻转它（它正在成为更大宏的一部分，为此必须使用 VBA）

我需要列标题的日期和唯一名称列表。 列中将显示该日期的工作。 请参阅下面的示例：

我已经能够获得 select 所有包含人名的行的代码，但是我无法通过每个选定的行来逐一练习 go，复制工作代码并将其粘贴到下的新表中正确的对应日期。

由于某些工作有多个人，此代码使用 InStr() 来查找出现的 unqiue 名称

Sub NewTable()

 Dim Rng As Range
 Dim Cell As Object
 Dim Found As Range
 
 Dim Ws As Worksheet
 Set Ws = Worksheets("Sheet1")
 
 Set Rng = Ws.Range("D:D")
 searchString = "Emily"
 For Each Cell In Rng
 If InStr(Cell, searchString) > 0 Then
      If Not Found Is Nothing Then
          Set Found = Union(myUnion, Cell.EntireRow)
      Else
          Set Found = Cell.EntireRow
      End If
 End If
 Next
 If Found Is Nothing Then
     MsgBox "The text was not found in the selection"
 Else
     Found.Select
 End If

End Sub

任何帮助，将不胜感激

Answer 1

试试这个：

Sub Tester()

    Dim rw As Range, wsData As Worksheet, wsPivot As Worksheet, arr, e, r, c
    
    Set wsData = ThisWorkbook.Worksheets("Input")  'sheet with original data
    Set wsPivot = ThisWorkbook.Worksheets("Pivot") 'sheet for the final table
    
    'loop over each row in the input table
    For Each rw In wsData.Range("B6:E" & wsData.Cells(Rows.Count, "B").End(xlUp).Row).Rows
        If Application.CountA(rw) = 3 Then 'row has data?
        
            'try to match the date: add as new date if no match
            c = Application.Match(CLng(rw.Cells(3).Value), wsPivot.Rows(1), 0)
            If IsError(c) Then
                c = wsPivot.Cells(1, Columns.Count).End(xlToLeft).Column + 1
                If c < 4 Then c = 4 'dates start in D1
                wsPivot.Cells(1, c).Value = rw.Cells(3).Value 'add the date
            End If
            
            arr = Split(rw.Cells(2).Value, ",") 'get array of all names
            'check row for each name: add as new name if no match
            For Each e In arr
                'look for the name in Col B
                r = Application.Match(Trim(e), wsPivot.Columns("B"), 0)
                'if name not found, then add it in the next empty cell
                If IsError(r) Then
                    r = wsPivot.Cells(Rows.Count, "B").End(xlUp).Row + 1
                    If r < 4 Then r = 4 'names begin in B4
                    wsPivot.Cells(r, "B").Value = e
                End If
                wsPivot.Cells(r, c).Value = rw.Cells(1).Value 'add the Job Code
            Next e
        End If
    Next rw
End Sub