Сообщество Чайников

Вопрос

Понадобилось в Excel (vba) выполнить такое:

есть директория, в ней файлы формата xls, файлов переменное количество, называются они 1.xls, 2xls, 3xls…, n.xls

Структура файла такова:

два столбца с неограниченным количеством строк. Первый столбец — параметр, второй — значение. Необходимо программно определить и по возможности записать в файл или вывести на форму имя того файла, в котором какой-то конкретный параметр имеет наименьшее значение. Номера строк для одинаковых параметров в разных файлах не совпадают.

Понимаю, что долго сложно и мутарно, буду благодарен даже за помощь кусками, типа, к получит содержимое ячейки, как получить содержимое каталога, как…, ну вообщем поняли.

Ответ

Option Explicit

Function GetMinParamInFiles(Adir As String,
AParam As String) As String Dim iFile As Long,
resFile As String Dim MinValue As Variant, curvalue As Variant Const xlExt As String = ".xls"

' Ищем первый файл содержащий значение
iFile = 1
MinValue = Null
Do
resFile = Dir(Adir + CStr(iFile) + xlExt)
iFile = iFile + 1
If iFile >= 100 Then Exit Do
If Not resFile = "" Then
MinValue = GetMinParamInFile(Adir + resFile, AParam)
End If
Loop While (resFile = "") Or IsNull(MinValue)

' если нашли такой файл считем его за минимум и ищем дальше
If Not (resFile = "") And Not IsNull(MinValue) Then
MinValueFile = resFile
Do
resFile = Dir(Adir + CStr(iFile) + xlExt)
iFile = iFile + 1
If Not resFile = "" Then
curvalue = GetMinParamInFile(Adir + resFile, AParam)
If Not IsNull(curvalue) Then
If curvalue < MinValue Then
MinValue = curvalue
MinValueFile = resFile
End If
End If
End If
Loop Until (resFile = "")
End If

If IsNull(MinValue) Then
GetMinParamInFiles = ""
Else
GetMinParamInFiles = MinValueFile
End If

End Function

Function GetMinParamInFile(AFilename As String, AParam As String) As Variant
' Поиск значения заданного параметра в заданном файле
' Если такого параметра нет возвращается Null

Dim wb As Workbook
Set wb = Workbooks.Open(AFilename)
Dim ws As Worksheet
' Здесь я принимаю, что параметры хранятся на активном листе
Set ws = wb.ActiveSheet
Dim iRow As Long
iRow = 1
Dim Pname As String, Pvalue As Variant
Pvalue = Null
Pname = Trim(ws.Cells(iRow, 1).Value)
Do While Not Pname = ""
If Pname = AParam Then
Pvalue = Trim(ws.Cells(iRow, 2).Value)
Exit Do ' считаю что параметр в файле встречается всего один раз
End If
iRow = iRow + 1
Pname = Trim(ws.Cells(iRow, 1).Value)
Loop
wb.Close
GetMinParamInFile = Pvalue
End Function

Sub test()
MsgBox GetMinParamInFiles("c:\мои документы\", "p4")
End Sub

Из конференции Expert_FAQ