VBA程序集(第3辑)

VBA程序集 (第3辑) ********************************** 程序11(查找) [程序功能] 将数值转换为文本 [程序作用] 搜索选中的列，将数值转变为文本。如果只选择了一个单元格，那么代码仅在活动单元格中操作。不能对公式单元格和空单元格操作。 [程序扩展] 可以将程序代码1和程序代码2略加改动，将一个字符附加到所选单元格的开头。如将cell.Value = "'" & cell.Value换成cell.value="/”I”&cell.Value，则在所选单元格开头添加字符“I”，即可统一单元格开始形式。 [程序代码1] Sub" 数值转换为文本1() '通过添加'号     Dim cell As Range     For Each cell In Selection         If Not cell.HasFormula Then             If Not IsEmpty(cell) Then                 cell.Value = "'" & cell.Value             End If         End If     Next End Sub [程序代码2] Sub 数值转换成文本2() '只对数字单元格进行操作     Dim cell As Range     For Each cell In Selection         If Not cell.HasFormula Then             If Not IsEmpty(cell) Then                 If IsNumeric(cell) Then                     cell.Value = "'" & cell.Value '可根据需要变换字符                 End If             End If         End If     Next End Sub [程序代码3] Sub 数值转换为文本3() '通过格式     Dim cell As Range     For Each cell In Selection         If Not cell.HasFormula Then             If Not IsEmpty(cell) Then                 Selection.NumberFormatLocal = "@"             End If         End If     Next End Sub UploadFiles/2006-6/623592706.rar ********************************** 程序12(查找) [程序功能] 根据列条件复制行到新工作表中 [程序说明] 创建新的工作表，将A列中的各产品分别归入相应的工作表中。 [程序扩展] 根据不同的实际情况，稍做调整后即可应用，主要是方法，即可根据某列中的单元格将相应的行归于相应的工作表。 [程序代码] 情形一：将各产品分解到相应的工作表中，本例中A列产品名称是单一的,且仅有一个车间生产。 Sub 复制数据到新工作表()     Dim CLL As Range, TotalWS As Worksheet, PartWS As Worksheet     Application.ScreenUpdating = False     Set TotalWS = Sheets("总表")     Worksheets.Add(After:=TotalWS).Name = "四车间"     Worksheets.Add(After:=TotalWS).Name = "三车间"     Worksheets.Add(After:=TotalWS).Name = "二车间"     Worksheets.Add(After:=TotalWS).Name = "一车间"      '复制表头到各新工作表     With TotalWS.Rows(1)         .Copy Sheets("一车间").Rows(1)         .Copy Sheets("二车间").Rows(1)         .Copy Sheets("三车间").Rows(1)         .Copy Sheets("四车间").Rows(1)     End With            '在汇总工作表中,从A列的第2个单元格开始查找      '检查每个单元格内容并设置相应的工作表      '如果找到则复制到相应的工作表中     For Each CLL In TotalWS.Range("A2", TotalWS.Cells(TotalWS.Rows.Count, 1).End(xlUp))         '检查每个单元格并与相应的工作表对应         Select Case Trim(UCase(CLL.Text))         Case "A产品", "E产品": Set PartWS = Sheets("一车间")         Case "B产品": Set PartWS = Sheets("二车间")         Case "C产品", "F产品": Set PartWS = Sheets("三车间")         Case "D产品": Set PartWS = Sheets("四车间")         Case Else: Set PartWS = Nothing         End Select         '如果数据存在则复制到目标工作表         If Not PartWS Is Nothing Then             CLL.EntireRow.Copy PartWS.Rows(PartWS.UsedRange.Rows.Count + 1)         End If      Next      Application.ScreenUpdating = True      '释放变量     Set CLL = Nothing     Set TotalWS = Nothing     Set PartWS = Nothing End Sub UploadFiles/2006-6/623661810.rar 情形二：将各产品分解到相应的工作表中。本例中A列产品名称是单一的,但有部分产品多个车间均生产，如：1、A产品一车间和三车间均生产；2、C产品三车间和四车间均生产。 Sub 复制数据到新工作表()     Dim CLL As Range, TotalWS As Worksheet, PartWS As Worksheet     Application.ScreenUpdating = False     Set TotalWS = Sheets("总表")     Worksheets.Add(After:=TotalWS).Name = "四车间"     Worksheets.Add(After:=TotalWS).Name = "三车间"     Worksheets.Add(After:=TotalWS).Name = "二车间"     Worksheets.Add(After:=TotalWS).Name = "一车间"            '复制表头到各新工作表     With TotalWS.Rows(1)         .Copy Sheets("一车间").Rows(1)         .Copy Sheets("二车间").Rows(1)         .Copy Sheets("三车间").Rows(1)         .Copy Sheets("四车间").Rows(1)     End With            '在汇总工作表中,从A列的第2个单元格开始查找      '检查每个单元格内容并设置相应的工作表      '如果找到则复制到相应的工作表中     For Each CLL In TotalWS.Range("A2", TotalWS.Cells(TotalWS.Rows.Count, 1).End(xlUp))          '检查每个单元格并与相应的工作表对应         Select Case Trim(UCase(CLL.Text))         Case "A产品"           Set PartWS = Sheets("一车间")           CLL.EntireRow.Copy PartWS.Rows(PartWS.UsedRange.Rows.Count + 1)           Set PartWS = Sheets("三车间")         Case "E产品": Set PartWS = Sheets("一车间")         Case "B产品": Set PartWS = Sheets("二车间")         Case "C产品"           Set PartWS = Sheets("三车间")           CLL.EntireRow.Copy PartWS.Rows(PartWS.UsedRange.Rows.Count + 1)           Set PartWS = Sheets("四车间")         Case "F产品": Set PartWS = Sheets("三车间")         Case "D产品": Set PartWS = Sheets("四车间")         Case Else: Set PartWS = Nothing         End Select         '如果数据存在则复制到目标工作表         If Not PartWS Is Nothing Then             CLL.EntireRow.Copy PartWS.Rows(PartWS.UsedRange.Rows.Count + 1)         End If     Next     Application.ScreenUpdating = True      '释放变量     Set CLL = Nothing     Set TotalWS = Nothing     Set PartWS = Nothing End Sub UploadFiles/2006-6/623332769.rar 情形三：将各产品分解到相应的工作表中。本例中A列部分单元格包含多种产品名称，且有几种产品几个车间均生产，即：1、第8列包含2种产品,第10列包含3种产品分属不同车间,要归入不同的工作表中；2、F产品三车间和四车间均生产,归入相应工作表中；3、J产品一车间和三车间均生产，归入相应工作表中。 Sub 复制数据到新工作表()     Dim CLL As Range, TotalWS As Worksheet     Application.ScreenUpdating = False     Set TotalWS = Sheets("总表")     Worksheets.Add(After:=TotalWS).Name = "四车间"     Worksheets.Add(After:=TotalWS).Name = "三车间"     Worksheets.Add(After:=TotalWS).Name = "二车间"     Worksheets.Add(After:=TotalWS).Name = "一车间"            '复制表头到各新工作表     With TotalWS.Rows(1)         .Copy Sheets("一车间").Rows(1)         .Copy Sheets("二车间").Rows(1)         .Copy Sheets("三车间").Rows(1)         .Copy Sheets("四车间").Rows(1)     End With            '在汇总工作表中,从A列的第2个单元格开始查找      '检查每个单元格内容并设置相应的工作表      '如果找到则复制到相应的工作表中     For Each CLL In TotalWS.Range("A2", TotalWS.Cells(TotalWS.Rows.Count, 1).End(xlUp))          '检查每个单元格并与相应的工作表对应         CheckProduct CLL, Sheets("一车间"), "A产品"         CheckProduct CLL, Sheets("一车间"), "E产品"         CheckProduct CLL, Sheets("二车间"), "B产品"         CheckProduct CLL, Sheets("三车间"), "C产品"         CheckProduct CLL, Sheets("三车间"), "F产品"         CheckProduct CLL, Sheets("四车间"), "F产品"         CheckProduct CLL, Sheets("四车间"), "D产品"         CheckProduct CLL, Sheets("一车间"), "G产品"         CheckProduct CLL, Sheets("二车间"), "H产品"         CheckProduct CLL, Sheets("三车间"), "I产品"         CheckProduct CLL, Sheets("一车间"), "J产品"         CheckProduct CLL, Sheets("三车间"), "J产品"         CheckProduct CLL, Sheets("二车间"), "K产品"         CheckProduct CLL, Sheets("二车间"), "L产品"     Next     Application.ScreenUpdating = True      '释放变量     Set CLL = Nothing     Set TotalWS = Nothing End Sub ***************************** Private Function CheckProduct(ByVal CLL As Range, ByVal PartWS As Worksheet, ByVal Product As String) As Boolean     If InStr(1, UCase(CLL.Text), Product) > 0 Then         With PartWS             CLL.EntireRow.Copy .Rows(.UsedRange.Rows.Count + 1)             .Cells(.UsedRange.Rows.Count, 1).Value = Product         End With     End If End Function UploadFiles/2006-6/623380560.rar