Option Explicit
Private Function fnExtractFileName(ByVal vName As String) As String
Dim vArr() As String
vArr = Split(vName, Application.PathSeparator)
fnExtractFileName = vArr(UBound(vArr))
End Function
Private Function fnExtractFilePath(ByVal vName As String) As String
Dim vArr() As String
vArr = Split(vName, Application.PathSeparator)
If UBound(vArr) = 0 Then Exit Function
ReDim Preserve vArr(UBound(vArr) - 1)
fnExtractFilePath = Join(vArr, Application.PathSeparator)
End Function
Private Function fnGetFileToOpen(s As String) As String
Dim aa As Variant
aa = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xls*", Title:=s, MultiSelect:=False)
If aa <> False Then fnGetFileToOpen = aa Else fnGetFileToOpen = ""
End Function
Private Function fnGetFileList(aPath As String, aMask As String) As String
Dim aa As String, cc As String
aa = Dir(aPath & "\" & aMask)
While aa <> ""
cc = cc & aa & vbLf
aa = Dir
Wend
If cc <> "" Then cc = Left(cc, Len(cc) - 1)
fnGetFileList = cc
End Function
Sub suGetFullList()
Dim aFile As String, aList As String, aName As String, aPath As String, aMask As String, cc() As String, ii As Integer
Dim firstAddress As String, aRange As String, aStart As String, aTime As String, aDay As String, aHeader As String, aBook As String
Dim oSheet As Object, c As Object, RetVal As Double, aRow As Long
aBook = ActiveWorkbook.Name
aFile = fnGetFileToOpen("Выберите необходимый файл с данными")
If aFile = "" Then Exit Sub
aPath = fnExtractFilePath(aFile)
aMask = Left(fnExtractFileName(aFile), 6) & "*.xls*"
aList = fnGetFileList(aPath, aMask)
cc = Split(aList, vbLf)
aName = InputBox("Введите номер узла")
aHeader = "День" & vbTab & "Час" & vbTab & "ЧАС расчета" & vbTab & "Значения цены"
aList = ""
For ii = LBound(cc) To UBound(cc)
Workbooks.Open Filename:=aPath & "\" & cc(ii)
aDay = Mid(ActiveWorkbook.Name, 7, 2)
For Each oSheet In ActiveWorkbook.Sheets
aTime = Format(oSheet.Name & ":00:00", "hh:mm:ss")
aRow = oSheet.Cells(Rows.Count, 1).End(xlUp).Row
aRange = Split(Cells(1, 1).Address(True, False, xlA1), "$")(0) + CStr(4) + ":" + _
Split(Cells(1, 1).Address(True, False, xlA1), "$")(0) + CStr(aRow)
aStart = Split(Cells(1, 1).Address(True, False, xlA1), "$")(0) + CStr(aRow)
With oSheet.Range(aRange)
Set c = .Find(aName, After:=oSheet.Range(aStart), LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
aList = aList & vbCrLf & aDay & vbTab & aTime & vbTab & oSheet.Name & vbTab & oSheet.Cells(c.Row, 6).Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
Else
End If
End With
Next
Next ii
Set c = Nothing
Set oSheet = Nothing
If aList = "" Then
MsgBox "Номер узла не найден."
Exit Sub
End If
aList = aHeader & aList
Workbooks(aBook).Activate
cc = Split(aList, vbCrLf)
[A1].Resize(UBound(cc)) = WorksheetFunction.Transpose(cc)
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
True
Columns("A:D").AutoFit
ActiveSheet.Name = Mid(aMask, 5, 2) & "-" & aName
End Sub
|
