根据列A将数据移动到1行，从列D移动数据和时间

Question

我认为这张照片几乎可以告诉你我想达到的目标。

我仍然可以试着解释一下。

我有顶部表5列A B C dË

列A是主要含有货号与个人号码它最多可以有8个记录的记录。

我需要将所有记录放在NUM的1行中。

是排序A和D.

我只需要根据时间，它发生在移动C列。

我刚刚添加了额外的列，因为我最多可以有8个非创建和最多4个原因创建记录。

Answer 1

我假定的follwoing

1. 表中的一个是在表称为“输入”
2. 将在片材中产生的输出称为“输出”，其已经在报头将

粘贴此代码模块中并运行它

Option Explicit 

Sub Sample() 
    Dim wsInput As Worksheet, wsOutput As Worksheet 
    Dim wsILrow As Long, wsOLrow As Long, i As Long, c As Long, nc As Long 
    Dim wsIrng As Range, fltrdRng As Range, cl As Range 
    Dim col As New Collection 
    Dim itm 

    Set wsInput = Sheets("Input") 
    Set wsOutput = Sheets("Output") 

    With wsInput 
     wsILrow = .Range("A" & .Rows.Count).End(xlUp).Row 

     Set wsIrng = .Range("A1:E" & wsILrow) 

     With wsIrng 
      .Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("D2") _ 
      , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _ 
      , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _ 
      xlSortNormal 
     End With 

     For i = 2 To wsILrow 
      On Error Resume Next 
      col.Add .Cells(i, 1).Value, Chr(34) & .Cells(i, 1).Value & Chr(34) 
      On Error GoTo 0 
     Next i 
    End With 

    wsOLrow = 2 

    With wsOutput 
     For Each itm In col 
      .Cells(wsOLrow, 1).Value = itm 
      wsOLrow = wsOLrow + 1 
     Next 

     wsOLrow = .Range("A" & .Rows.Count).End(xlUp).Row 

     For i = 2 To wsOLrow 
      With wsInput 
       '~~> Remove any filters 
       .AutoFilterMode = False 

       With wsIrng '<~~ Filter, offset(to exclude headers) 
        .AutoFilter Field:=1, Criteria1:=wsOutput.Cells(i, 1).Value 
        Set fltrdRng = .Offset(1, 0).SpecialCells(xlCellTypeVisible) 
       End With 

       '~~> Remove any filters 
       .AutoFilterMode = False 
      End With 

      '<~~ c is for Cause column and nc is for non cause 
      c = 3: nc = 7 

      For Each cl In fltrdRng.Cells 
       If cl.Column = 3 And Len(Trim(cl.Value)) <> 0 Then 
        If InStr(1, cl.Value, "Cause", vbTextCompare) Then 
         .Cells(i, c).Value = wsInput.Cells(cl.Row, 3).Value 
         c = c + 1 
        ElseIf InStr(1, cl.Value, "Non", vbTextCompare) Then 
         .Cells(i, nc).Value = wsInput.Cells(cl.Row, 3).Value 
         nc = nc + 1 
        End If 

        .Cells(i, 2).Value = wsInput.Cells(cl.Row, 2).Value 
        .Cells(i, 15).Value = wsInput.Cells(cl.Row, 5).Value 
       End If 
      Next 
     Next i 
    End With 
End Sub 

截图

输入页

输出薄片

注：任何未来的结构的变化必须也包含在代码中。