|
今天就带大家利用这套教材的内容完成一个稍微复杂的程序制作，需求如下： 1．首先用户要和计算机进行对话，用户将录入一个人名的数据 2．VBA程序要根据用户的需求，在工作'数据1'的工作表中进行A列的完全匹配查找（为了减少篇幅，我设定是唯一的值） 3．找到数据后，要把数据导出到一个文本文件，反馈给用户。 上述的过程其实是很多地方大家都会看到的，或者有这类程序的影子，只不过要比上面的要求是复杂些，我这里就只讲些方法，具体的应用是千差万别的，让读者自己发挥吧。 为了实现上述的三个需求我们设计了如下的步骤： 步骤1 ：利用INPUTBOX 函数进行人机对话 步骤2 ：利用FIND 函数进行查找 步骤3 ：利用CreateTextFile方法创建文本文件反馈，作为客户的需求。 思路有了，下面我们要准备我们的'积木'了，打开《VBA代码解决方案》第一册： 找到第40讲和第7讲： 打开《VBA代码解决方案》第二册： 找到第77讲或78讲 分别考出上述第40、第7、 第77讲的代码。 第40讲inputbox代码：（积木1） SubMyInputBox() Dim sInt As String Dim r As Integer r = Sheet1.Range('A65536').End(xlUp).Row sInt = InputBox('请输入添加人员的姓名：') If Len(Trim(sInt)) > 0 Then Sheet1.Cells(r + 1, 1) = sInt Else MsgBox '您没有输入内容!' End If End Sub 第7讲find代码：（积木2） SubmyFind() Dim StrFind As String Dim Rng As Range StrFind = InputBox('请输入要查找的值:') If Trim(StrFind) <> '' Then With Sheet1.Range('A:A') Set Rng = .Find(What:=StrFind, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng Is Nothing Then Application.Goto Rng, True Else MsgBox '没有找到该单元格!' End If End With End If End Sub 第77讲CreateTextFile方法代码：（积木3） Sub MyCreText() Dim MyFile As Object Dim myStr As String Dim j As Integer, iAs Integer Set MyFile = CreateObject('Scripting.FileSystemObject') _ .CreateTextFile(ThisWorkbook.Path & '\' & '人员表单.txt', True) For i = 1 To Range('A65536').End(xlUp).Row myStr = '' For j = 1 To Range('IV'& i).End(xlToLeft).Column myStr = myStr & Cells(i, j) & ',' Next myStr = Left(myStr, (Len(myStr) -1)) MyFile.WriteLine (myStr) Next MyFile.Close Set MyFile = Nothing End Sub 我们的积木就准备好了，当然这些积木读者要了然于胸啊，这样才能去快速的找到。下面我们要搭建积木了，我们注意到上述第7讲FIND函数的代码中包含了第40讲的INPUTBOX的代码，那么这就可以略去了第40讲的内容了，把积木1扔掉，用积木2和3即可，直接把积木2FIND的代码拷贝如下，同时为了看清楚，修正一下格式： Sub myFind() Dim StrFind As String Dim Rng As Range StrFind = InputBox('请输入要查找的值:') If Trim(StrFind) <> '' Then With Sheet1.Range('A:A') Set Rng = .Find(What:=StrFind, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng Is Nothing Then Application.Goto Rng, True '找到值后将执行的操作 Else MsgBox '没有找到该单元格!' End If End With End If End Sub 上述代码中找到值后将执行的是： Application.Goto Rng, True 操作，而我们要求执行的是数据的导出操作，那么好了，就把上述Application.Goto Rng, True 操作换成代码77讲的内容就OK了。 下面为修正后的代码及其注释： Public myhs As Integer '设置全局变量，用来传递找到了要找的人名时记录该单元格的行数 Sub myFind() Dim StrFind As String Dim Rng As Range StrFind = InputBox('请输入要查找的人名:') '步骤1 利用INPUTBOX 函数进行人机对话 If Trim(StrFind) <> '' Then '要求用户录入的数据不能为空值 With Sheets('数据1').Range('A:A') '此处修正了工作表的名称 '完全匹配查找，完成步骤2 利用FIND 函数进行查找 Set Rng = .Find(What:=StrFind, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng Is Nothing Then myhs = Rng.Row '设置传递函数，当找到了要找的人名时记录该单元格的行数 MyCreText '如果找到了用户要求的人名将进入MyCreText过程 Else MsgBox '没有找到该人名!' End If End With End If End Sub Sub MyCreText() '如果找到了用户要求的人名将执行步骤3 利用CreateTextFile方法创建文本文件作为客户的需求。 Dim MyFile As Object Dim myStr As String Dim j As Integer ', i As Integer I的变量去掉，用了Myhs Set MyFile = CreateObject('Scripting.FileSystemObject') _ .CreateTextFile(ThisWorkbook.Path & '\' & '人员资料.txt', True) '把要输出的文件名称修正为人员资料 ' For i = 1 To Range('A65536').End(xlUp).Row '此行代码去掉，因为值是唯一的 myStr = '' For j = 1 To Range('IV' & myhs).End(xlToLeft).Column myStr = myStr & Cells(1, j) & ':' & Cells(myhs, j) & ', ' '此处修正代码加入输出数据的抬头 Next myStr = Left(myStr, (Len(myStr) - 1)) MyFile.WriteLine (myStr) 'Next '此行代码去掉，因为值是唯一的 MyFile.Close Set MyFile = Nothing MsgBox ('OK') '添加程序完成的提示 End Sub 代码截图： 上述的讲解中你会发现，有了'积木'，代码只是改了改。改动的幅度很少，这样大量的节约了你的大量时间。 下面我们看代码的执行： 数据1工作表的截图，我们要查找的是A115: 运行后提示输入要查找的人名： 运行结束： 运行结果显示：
再次重申一点，做程序就如同搭积木，尽可能不要去写代码，你把必要的积木块拿来，组合好，你要做的只是组合、修正即可，就这么简单。 我的《VBA代码解决方案》中会有各式各样的独立的积木，给你分享，给你利用。当然你要弄懂每讲的内容才能运用自如，才能组合、修正代码。 |
|
|
