|
|
MS Excel - Проверка наличия заданных полей среди всех листов книги (перед импортом например)
Пример эксплуатации:
Private Sub test0002()
Dim sPath$, sList$
Dim sWorksheetName As String
sPath = "d:\Temp\Tabel_05.xlsx"
sList = "DateReport, Affilate, TabNum, FIO, HirDate, DisDate, SR_Name_Rus, " & _
"Pr_Name_Rus, MainArea_VC, PersCatName, GrafikCode, Klg_Collar, " & _
"Holiday_Beg, Holiday_End, Illness_Beg, Illness_End, DecretN, UhodN"
sWorksheetName = CheckFieldsInExcelWB(sPath, sList, 64)
If sWorksheetName = "" Then
MsgBox "В файле:" & vbCrLf & sPath & vbCrLf & _
"Не обнаружено данных для импорта." & vbCrLf & _
"Пожалуйста укажите другой файл.", vbExclamation, "Ошибка! - Данные не найдены!"
Else
MsgBox "Файл:" & vbCrLf & sPath & vbCrLf & _
"Успешно прошел проверку." & vbCrLf & _
"В нем найден лист: [" & sWorksheetName & "].", vbInformation, "Данные найдены."
End If
End Sub
Private Function CheckFieldsInExcelWB(sFilePath$, sFieldsList$, Optional iFieldsEndCol% = 100) As String
Dim objExcelApp As Object
Dim objWorkBook As Object
Dim objWorkSheet As Object
Dim s$, iVal%, iValSub%, xVal%, vVal As Variant
Dim iTotalFields%, iFoundFields%
Dim arrFielsCheck() As String
Dim arrFielsIn() As String
On Error GoTo CheckFieldsInExcelWB_Err
s = sFieldsList
arrFielsCheck = Split(s, ",")
iTotalFields = UBound(arrFielsCheck)
If iTotalFields = 0 Then
MsgBox "Проверяемые поля не указаны!", vbCritical
GoTo CheckFieldsInExcelWB_End
End If
For iVal = LBound(arrFielsCheck) To iTotalFields
arrFielsCheck(iVal) = Trim(arrFielsCheck(iVal))
Next iVal
Set objExcelApp = CreateObject("Excel.Application")
Set objWorkBook = objExcelApp.Workbooks.Open(sFilePath)
s = ""
iTotalFields = iTotalFields + 1
For Each objWorkSheet In objWorkBook.WorkSheets
With objWorkSheet
For iVal = 1 To iFieldsEndCol
vVal = .Cells(1, iVal).Value
If vVal <> "" Then s = s & vVal & ";"
Next iVal
End With
arrFielsIn = Split(s, ";")
For iVal = LBound(arrFielsCheck) To UBound(arrFielsCheck)
For iValSub = LBound(arrFielsIn) To UBound(arrFielsIn)
s = arrFielsIn(iValSub)
If arrFielsCheck(iVal) = s Then 'поле найдено!
iFoundFields = iFoundFields + 1
'Debug.Print Format(iValSub + 1, "000"); " = N " & arrFielsIn(iValSub)
'Debug.Print "Найдено: " & iFoundFields & " из " & iTotalFields
Exit For
End If
Next iValSub
Next iVal
If iFoundFields >= iTotalFields Then 'всё найдено
CheckFieldsInExcelWB = objWorkSheet.Name
Exit For
End If
Next objWorkSheet
CheckFieldsInExcelWB_End:
On Error Resume Next
objWorkBook.Close
Set objWorkBook = Nothing
objExcelApp.Quit
Set objExcelApp = Nothing
Err.Clear
Exit Function
CheckFieldsInExcelWB_Err:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Function CheckFieldsInExcelWB.", _
vbCritical, "Произошла ошибка!"
Debug.Print "Line: " & Erl & "."
Err.Clear
Resume CheckFieldsInExcelWB_End
End Function
|
|