Ich habe ein wenig hässliches VBA geschrieben, aber es scheint zu funktionieren. Es gibt Raum für die Optimierung, da ich den Code wiederholt sehe. Es ist derzeit schwer codiert, um in die 7-Spalte-2. Zeile zu gelangen.
Option Explicit Sub I_O_single_line() Dim rng As Range Dim counter1 As Integer, counter2 As Integer, counter3 As Integer, LastRow As Integer, WriteRow As Integer, HeaderRow As Integer Dim wkb As Workbook Dim sht As Worksheet Dim Arr() As Variant Set wkb = ActiveWorkbook Set sht = wkb.Worksheets(1) 'Last row of header row information 'set to 0 if no header row HeaderRow = 1 'initializing the first row that the sorted data will be written to WriteRow = HeaderRow + 1 'Finds the last used row With sht If Application.WorksheetFunction.CountA(.Cells) <> 0 Then LastRow = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Else LastRow = 1 End If End With 'Resize the array to match your data ReDim Arr(LastRow - HeaderRow, 4) 'Copy the contents of the source data into an arr Arr() = Range(Cells(HeaderRow + 1, 1), Cells(LastRow, 4)) 'iterate through each row of the source data For counter1 = 1 To (LastRow - HeaderRow) 'first row of data is potentially a special case If counter1 = 1 Then 'Write out ID and Date For counter2 = 1 To 2 Cells(WriteRow, 6 + counter2) = Arr(counter1, counter2) Next counter2 'Write out Time in appropriate column If Arr(counter1, 4) = "I" Then Cells(WriteRow, 6 + 3) = Arr(counter1, 3) ElseIf Arr(counter1, 4) = "O" Then Cells(WriteRow, 6 + 4) = Arr(counter1, 3) WriteRow = WriteRow + 1 End If 'Check to see if ID changed ElseIf Arr(counter1 - 1, 1) = Arr(counter1, 1) Then 'Check to see if Date has changed If Arr(counter1 - 1, 2) = Arr(counter1, 2) Then 'Write out time in appropriate column If Arr(counter1, 4) = "I" Then 'Check if previous entry is a repeat If Arr(counter1 - 1, 4) = Arr(counter1, 4) Then 'Advance Write a new line WriteRow = WriteRow + 1 End If For counter2 = 1 To 3 Cells(WriteRow, 6 + counter2) = Arr(counter1, counter2) Next counter2 ElseIf Arr(counter1, 4) = "O" Then 'Check if previous entry is a repeat If Arr(counter1 - 1, 4) = Arr(counter1, 4) Then 'Write ID and Date For counter2 = 1 To 2 Cells(WriteRow, 6 + counter2) = Arr(counter1, counter2) Next counter2 End If Cells(WriteRow, 6 + 4) = Arr(counter1, 3) WriteRow = WriteRow + 1 End If 'What to do if date has changed Else If Arr(counter1 - 1, 4) = "I" Then WriteRow = WriteRow + 1 End If 'Write ID and Date For counter2 = 1 To 2 Cells(WriteRow, 6 + counter2) = Arr(counter1, counter2) Next counter2 'Write out Time in appropriate column If Arr(counter1, 4) = "I" Then Cells(WriteRow, 6 + 3) = Arr(counter1, 3) ElseIf Arr(counter1, 4) = "O" Then Cells(WriteRow, 6 + 4) = Arr(counter1, 3) WriteRow = WriteRow + 1 End If End If 'What to do if ID has change Else If Arr(counter1 - 1, 4) = "I" Then WriteRow = WriteRow + 1 End If 'Write ID and Date For counter2 = 1 To 2 Cells(WriteRow, 6 + counter2) = Arr(counter1, counter2) Next counter2 'Write out Time in appropriate column If Arr(counter1, 4) = "I" Then Cells(WriteRow, 6 + 3) = Arr(counter1, 3) ElseIf Arr(counter1, 4) = "O" Then Cells(WriteRow, 6 + 4) = Arr(counter1, 3) WriteRow = WriteRow + 1 End If End If Next counter1 End Sub
