在Excel中自动validation

我目前在Excel中有一个数据validation问题，可能是“过度思考”问题的受害者。

我的要求很简单 – 我收到大量的xls文件，都需要符合一个确切的格式。

例如，我需要收到的所有文件在单元格A1到A3中具有以下string：“FirstName”，“LastName”，“Email”。 （案件事宜）。

实际上，比这更多的标题，并且通过每个文件拖网，并确保所有的标题存在，拼写正确/在正确的情况下是非常繁琐和耗时的。 我相信可以在Visual Basic中创build一个模块或工具来检查格式，然后根据文件是否符合要求的格式返回正确/错误。

我已经看了正则expression式（但相信这可能是矫枉过正，因为我只需要精确匹配），并没有使用VB的经验。 我在网上寻找帮助 – 其中一些是有用的，其中一些已经太过先进，我需要的工具。

任何帮助是极大的赞赏。

谢谢。

Answer 1

如果您使用Windows，请执行以下操作：

1. 将下面的代码复制到一个文件中，并用* .vbs扩展名来命名。 “ExcelHeader.vbs”，并保存在某个地方，例如。 在你的桌面上
2. 把你想要检查标题的所有Excel文件放在一个文件夹中
3. 双击.vbs文件，并在出现提示时select该文件夹

然后，脚本将通过该文件夹运行，并告诉您哪些文件不符合您的标题要求。

（你也可以修改下面的代码以包含更多的头文件，这应该从下面的“Else If”部分中的评论中明显看出）。

Dim sFolder, fso, files, folder, objExcel, objWorkbook sFolder = SelectFolder( "" ) If sFolder = vbNull Then WScript.Echo "Cancelled" Else WScript.Echo "Selected Folder: """ & sFolder & """" End If ' use strPath to look for excel files list Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(sFolder) Set files = folder.Files Set objExcel = CreateObject("Excel.Application") For Each file In files Set objWorkbook = objExcel.Workbooks.Open(file) ' add more headers as you wish as ElseIf statements below If objExcel.Cells(1, 1).Value <> "FirstName" Then MsgBox(file & " is not correct.") ElseIf objExcel.Cells(1, 2).Value <> "LastName" Then MsgBox(file & " is not correct.") ElseIf objExcel.Cells(1, 3).Value <> "Email" Then MsgBox(file & " is not correct.") End If objExcel.ActiveWorkbook.Close(0) Next objExcel.Quit Function SelectFolder( myStartFolder ) ' This function opens a "Select Folder" dialog and will ' return the fully qualified path of the selected folder ' ' Argument: ' myStartFolder [string] the root folder where you can start browsing; ' if an empty string is used, browsing starts ' on the local computer ' ' Returns: ' A string containing the fully qualified path of the selected folder ' ' Written by Rob van der Woude ' http://www.robvanderwoude.com ' Standard housekeeping Dim objFolder, objItem, objShell ' Custom error handling On Error Resume Next SelectFolder = vbNull ' Create a dialog object Set objShell = CreateObject( "Shell.Application" ) Set objFolder = objShell.BrowseForFolder( 0, "Select Folder", 0, myStartFolder ) ' Return the path of the selected folder If IsObject( objfolder ) Then SelectFolder = objFolder.Self.Path ' Standard housekeeping Set objFolder = Nothing Set objshell = Nothing On Error Goto 0 End Function Function ReadExcel( myXlsFile, mySheet, my1stCell, myLastCell, blnHeader ) ' Function : ReadExcel ' Version : 2.00 ' This function reads data from an Excel sheet without using MS-Office ' ' Arguments: ' myXlsFile [string] The path and file name of the Excel file ' mySheet [string] The name of the worksheet used (eg "Sheet1") ' my1stCell [string] The index of the first cell to be read (eg "A1") ' myLastCell [string] The index of the last cell to be read (eg "D100") ' blnHeader [boolean] True if the first row in the sheet is a header ' ' Returns: ' The values read from the Excel sheet are returned in a two-dimensional ' array; the first dimension holds the columns, the second dimension holds ' the rows read from the Excel sheet. ' ' Written by Rob van der Woude ' http://www.robvanderwoude.com Dim arrData( ), i, j Dim objExcel, objRS Dim strHeader, strRange Const adOpenForwardOnly = 0 Const adOpenKeyset = 1 Const adOpenDynamic = 2 Const adOpenStatic = 3 ' Define header parameter string for Excel object If blnHeader Then strHeader = "HDR=YES;" Else strHeader = "HDR=NO;" End If ' Open the object for the Excel file Set objExcel = CreateObject( "ADODB.Connection" ) ' IMEX=1 includes cell content of any format; tip by Thomas Willig objExcel.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _ myXlsFile & ";Extended Properties=""Excel 8.0;IMEX=1;" & _ strHeader & """" ' Open a recordset object for the sheet and range Set objRS = CreateObject( "ADODB.Recordset" ) strRange = mySheet & "$" & my1stCell & ":" & myLastCell objRS.Open "Select * from [" & strRange & "]", objExcel, adOpenStatic ' Read the data from the Excel sheet i = 0 Do Until objRS.EOF ' Stop reading when an empty row is encountered in the Excel sheet If IsNull( objRS.Fields(0).Value ) Or Trim( objRS.Fields(0).Value ) = "" Then Exit Do ' Add a new row to the output array ReDim Preserve arrData( objRS.Fields.Count - 1, i ) ' Copy the Excel sheet's row values to the array "row" ' IsNull test credits: Adriaan Westra For j = 0 To objRS.Fields.Count - 1 If IsNull( objRS.Fields(j).Value ) Then arrData( j, i ) = "" Else arrData( j, i ) = Trim( objRS.Fields(j).Value ) End If Next ' Move to the next row objRS.MoveNext ' Increment the array "row" number i = i + 1 Loop ' Close the file and release the objects objRS.Close objExcel.Close Set objRS = Nothing Set objExcel = Nothing ' Return the results ReadExcel = arrData End Function 

PS感谢Rob van der Woude的底部function:)

Answer 2

下面的代码

• 打开由strFolderName指定的文件夹中的每个Excel文件

• 在第一张表格的前三个单元格上运行单个区分大小写的testing，并将所有文件名和testing结果写入strFolderName目录中的csv文件“ErrReport.csv” ，其中objTF.writeline strFileName & "," & (StrComp(StrTest, strArray, vbBinaryCompare) = 0)

  

   Sub FileChk() Dim Wb As Workbook Dim ws As Worksheet Dim objFSO As Object Dim objTF As Object Dim strFolderName As String Dim strFileName As String Dim strArray As String Dim StrTest As String strFolderName = "c:\temp\" strFileName = Dir(strFolderName & "*.xls*") strArray = Join(Array("FirstName", "LastName", "Email"), ",") Set objFSO = CreateObject("scripting.filesystemobject") Set objTF = objFSO.createtextfile(strFolderName & "ErrReport.csv") With Application .DisplayAlerts = False .EnableEvents = False .ScreenUpdating = False lngCalc = .Calculation .Calculation = xlCalculationManual End With Do While Len(strFileName) > 0 Set Wb = Workbooks.Open(strFolderName & strFileName) Set ws = Wb.Sheets(1) StrTest = Join(Application.Transpose(Range([ws].[a1], ws.[a3]).Value2), ",") objTF.writeline strFileName & "," & (StrComp(StrTest, strArray, vbBinaryCompare) = 0) Wb.Close False strFileName = Dir Loop With Application .CutCopyMode = False .DisplayAlerts = True .EnableEvents = True .ScreenUpdating = True .Calculation = lngCalc End With objTF.Close End Sub 

Answer 3

下面的vbs答案给出了与上面的Excel VBA相同的输出。 此版本完成后打开完整的报告。

 Dim objExcel Dim objFSO Dim objFolder Dim objFile Dim objTF Dim Wb Dim ws Dim strFolderName Dim strArray Dim StrTest Set objExcel = CreateObject("Excel.application") strFolderName = "c:\Temp" strArray = Join(Array("FirstName", "LastName", "Email"), ",") Set objFSO = CreateObject("scripting.filesystemobject") Set objFolder = objFSO.getFolder(strFolderName) Set objTF = objFSO.createtextfile(strFolderName & "ErrReport.csv") With objExcel .DisplayAlerts = False .EnableEvents = False .ScreenUpdating = False End With On Error Resume Next For Each objFile In objFolder.Files 'If Right$(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")) Like "xls" Then If Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")) like "xls*" Then Set Wb = objExcel.Workbooks.Open(objFile) Set ws = Wb.Sheets(1) StrTest = Join(objExcel.Transpose(ws.Range([ws].[a1], ws.[a3]).Value2), ",") objTF.writeline strFileName & "," & (StrComp(StrTest, strArray, vbBinaryCompare) = 0) Wb.Close False End If Next On Error GoTo 0 objTF.Close With objExcel .DisplayAlerts = True .EnableEvents = True .ScreenUpdating = True .Workbooks.Open (strFolderName & "\ErrReport.csv") .Visible = True End With