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