根據列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 

截圖

輸入頁

輸出薄片

注：任何未來的結構的變化必須也包含在代碼中。