Ну, я написал некрасивую часть VBA, но, похоже, она работает. Есть место для оптимизации, поскольку я вижу повторный код. В настоящее время это жестко запрограммировано, чтобы поместить в 7-й столбец 2-го ряда.
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