Это реализация моего предложения. Пожалуйста, попробуйте это. Ключевым является то, что данные записываются на выходной лист, оставляя оригинал без изменений. Вы можете заменить входные листы и добавить их в существующий выходной лист. Однако полученный новый выходной лист не будет иметь отсортированных строк и столбцов, поскольку сортировка выполняется до создания исходного выходного листа. Пожалуйста, попробуйте мой код и посмотрите, как вам это понравится.
Option Explicit
Enum Nws ' Worksheet navigation
NwsCapRow = 1
NwsFirstDataRow ' no value assigned means previous + 1
NwsBatch = 1 ' 1 = column A
NwsTime
NwsVolt
NwsTTime = 1 ' Output sheet:
Nws1stBatch = 5 ' could be any column on the right
End Enum
Sub SortToColumns()
' Variatus @STO 31 Jan 2020
Dim WsS As Worksheet ' Source (input)
Dim WsT As Worksheet ' Target (output)
Dim Rng As Range
Dim Fnd As Range
Dim Tmp As Variant
Dim Rls As Long ' WsS.last row
Dim Rs As Long, Rt As Long ' Source / Target row
Dim Cs As Long, Ct As Long ' Source / Target column
' This worksheet has your DAT files, in Excel format, appended
' below each other (no headers, no blank rows)
' A column A was inserted in which a unique identifier
' for each DAT file is written.
' (all entries from one file have the same identifier)
Set WsS = ThisWorkbook.Worksheets("Input") ' change the Ws name to suit
With ThisWorkbook.Worksheets
On Error Resume Next
Set WsT = .Item("Output") ' change to suit
If Err Then
Set WsT = .Add(After:=.Item(.Count))
With WsT
.Name = "Output" ' change to suit
' add captions & formatting here
End With
End If
End With
On Error GoTo 0
With WsS
Rls = .Cells(.Rows.Count, NwsBatch).End(xlUp).Row
Cs = .UsedRange.Columns.Count
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsBatch), .Cells(Rls, Cs))
With .Sort.SortFields
.Clear
.Add Key:=Rng.Columns(NwsTime), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Rng.Columns(NwsBatch), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
End With
With .Sort
.SetRange Rng
.Header = xlGuess
.MatchCase = False ' change to suit
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
With WsT
For Rs = NwsFirstDataRow To Rls
Ct = Application.Max(.Cells(NwsCapRow, .Columns.Count).End(xlToLeft).Column, Nws1stBatch)
Set Rng = .Range(.Cells(NwsCapRow, Nws1stBatch), .Cells(NwsCapRow, Ct))
Tmp = WsS.Cells(Rs, NwsBatch).Value
Set Fnd = Rng.Find(Tmp, Rng.Cells(Rng.Cells.Count), xlValues, xlWhole, xlByColumns, xlNext)
If Fnd Is Nothing Then
Ct = Rng.Column + IIf(Rng.Cells(1).Value = "", Rng.Cells.Count, 0)
.Cells(NwsCapRow, Ct).Value = Tmp
Else
Ct = Fnd.Column
End If
Rt = Application.Max(.Cells(.Rows.Count, NwsTTime).End(xlUp).Row + 1, 2)
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsTTime), .Cells(Rt, NwsTTime))
Tmp = WsS.Cells(Rs, NwsTime).Value
Set Fnd = Rng.Find(Tmp, Rng.Cells(Rng.Cells.Count), xlValues, xlWhole, xlByRows, xlNext)
If Not Fnd Is Nothing Then Rt = Fnd.Row
.Cells(Rt, NwsTTime).Value = WsS.Cells(Rs, NwsTime).Value
.Cells(Rt, Ct).Value = WsS.Cells(Rs, NwsVolt).Value
Next Rs
End With
End Sub