BaseForm
'----- 'BaseForm '----- '画面初期化 Private Sub Form_Load() '磁盘路径 Drive_Path = "D:" '文件夹路径 Dir_Path = "D:" '新旧文件路径 Old_filepath_txt.Text = "" New_filepath_txt.Text = "" End Sub Private Sub OLD_xls_cmd_1_Click() '原旧文件路径 取得 Select_File_Path = Old_filepath_txt.Text File_Select_From.Show 1 '旧文件路径 设定 Old_filepath_txt.Text = Select_File_Path End Sub Private Sub NEW_xls_cmd_2_Click() '原新文件路径 取得 Select_File_Path = New_filepath_txt.Text File_Select_From.Show 1 '新文件路径 设定 New_filepath_txt.Text = Select_File_Path End Sub '比较按钮 Private Sub Diffent_cmd_Click() '输入的文件路径 检查 If FilePath_Check = False Then Exit Sub End If '新旧Excel 比较实施 Call Excel_diff MsgBox ("OK") End Sub '输入的文件路径 检查 Private Function FilePath_Check() As Boolean FilePath_Check = True '旧文件是否Excel文件检查 If Right(Trim(Old_filepath_txt.Text),3) <> "xls" Then '警告提示 MsgBox ("输入的旧文件并非EXCEL文件") '旧文件输入框 光标选中 Old_filepath_txt.SetFocus FilePath_Check = False Exit Function End If '旧文件 是否存在检查 If Dir(Old_filepath_txt.Text) = "" Then '警告提示 MsgBox ("输入的旧文件不存在") '旧文件输入框 光标选中 Old_filepath_txt.SetFocus FilePath_Check = False Exit Function End If '新文件是否Excel文件检查 If Right(Trim(New_filepath_txt.Text),3) <> "xls" Then '警告提示 MsgBox ("输入的新文件并非EXCEL文件") '新文件输入框 光标选中 New_filepath_txt.SetFocus FilePath_Check = False Exit Function End If '新文件 是否存在检查 If Dir(New_filepath_txt.Text) = "" Then '警告提示 MsgBox ("输入的新文件不存在") '新文件输入框 光标选中 New_filepath_txt.SetFocus FilePath_Check = False Exit Function End If '新旧文件路径 是否相同检查 If Trim(Old_filepath_txt.Text) = Trim(New_filepath_txt.Text) Then '警告提示 MsgBox ("输入的新旧文件路径相同 为同一个文件") '旧文件输入框 光标选中 Old_filepath_txt.SetFocus FilePath_Check = False Exit Function End If End Function '新旧Excel 比较实施 Private Sub Excel_diff() '创建EXCEL应用类 Dim MyXls As Object Set MyXls = CreateObject("Excel.Application") '旧Excel文件 Dim Old_WorkBook As Object Set Old_WorkBook = MyXls.Workbooks.Open(Trim(Old_filepath_txt.Text)) '新Excel文件 Dim New_WorkBook As Object Set New_WorkBook = MyXls.Workbooks.Open(Trim(New_filepath_txt.Text)) '新旧Excel比较结果Excel文件 Dim Result_WorkBook As Object Set Result_WorkBook = MyXls.Workbooks.Add Dim i As Integer Dim j As Integer '旧Excel文件Sheet循环 For i = 1 To Old_WorkBook.sheets.Count '新Excel文件Sheet循环 For j = 1 To New_WorkBook.sheets.Count '新旧excel文件中相同sheet名的sheet作对比 If Old_WorkBook.sheets(i).Name = New_WorkBook.sheets(j).Name Then '复制旧文件中要做对比的sheet至 结果Excel 复制至最后位置sheet Old_WorkBook.sheets(i).Copy After:=Result_WorkBook.Worksheets(Result_WorkBook.sheets.Count) ' '具体处理。。。 ' End If Next Next '新旧Excel文件关闭 Old_WorkBook.Close (True) New_WorkBook.Close (True) '比较结果Excel文件多余sheet删除 If Result_WorkBook.sheets.Count > 3 Then For i = Result_WorkBook.sheets.Count To 1 Step -1 If Result_WorkBook.sheets(i).Name = "Sheet1" _ Or Result_WorkBook.sheets(i).Name = "Sheet2" _ Or Result_WorkBook.sheets(i).Name = "Sheet3" Then Result_WorkBook.sheets(i).Delete End If Next End If 'EXCEL文件可见 MyXls.Visible = True End Sub '旧文件路径输入框 光标进入 Private Sub Old_filepath_txt_GotFocus() Old_filepath_txt.SelStart = 0 Old_filepath_txt.SelLength = Len(Old_filepath_txt.Text) End Sub '新文件路径输入框 光标进入 Private Sub New_filepath_txt_GotFocus() New_filepath_txt.SelStart = 0 New_filepath_txt.SelLength = Len(New_filepath_txt.Text) End Sub
File_Select_Form
'-------------------- '文件选择目录 联动设定 '-------------------- ' 联动Flg Private Init_Flg As String '初期化时 各列表框不联动(0:初期化,1:非初期化) '画面初期化 Private Sub Form_Load() '初期化开始Flg Init_Flg = "0" '磁盘 Drive1.Drive = Drive_Path '文件夹 Dir1.Path = Dir_Path '文件 File1.Path = Dir_Path '初期化结束Flg Init_Flg = "1" End Sub '磁盘列表 选择变更 Private Sub Drive1_Change() '非初期化时 变更的场合 联动实施 If Init_Flg = "1" Then Drive_Path = Drive1.Drive '文件夹列表 联动 Dir1.Path = Drive1.Drive End If End Sub '文件夹列表 选择变更 Private Sub Dir1_Change() '非初期化时 变更的场合 联动实施 If Init_Flg = "1" Then Dir_Path = Dir1.Path '文件列表 联动 File1.Path = Dir1.Path End If End Sub '文件列表 双击 Private Sub File1_DblClick() Call Return_File_Path End Sub '选择按钮 按下 Private Sub Select_cmd_Click() Call Return_File_Path End Sub '返回文件路径 并关闭窗口 Private Sub Return_File_Path() '取得的文件路径 设定 Select_File_Path = Dir1.Path If Right(Dir1.Path,1) <> "\" Then Select_File_Path = Select_File_Path & "\" End If Select_File_Path = Select_File_Path & File1.FileName '关闭窗口 Unload Me End Sub
Module1
'磁盘路径 全局变量 Global Drive_Path As String '文件夹路径 全局变量 Global Dir_Path As String '取得Excel文件路径 Global Select_File_Path As String