Excel VBA 从一个工作簿查找另一个一个工作簿中的一些内容复制到另外一个工作簿 |
您所在的位置：网站首页 › 如何在工作薄中查找数据在那个工作表里 › Excel VBA 从一个工作簿查找另一个一个工作簿中的一些内容复制到另外一个工作簿 |
|
帮朋友来写个Excel VBA 以前写过ASP，所以对vb略微熟悉，但VBA 没有仔细研究过。 以前只研究过 vba 写一个 计算个人所得税的程序。 这次写的功能也算是简单，但也耗费了两天的功夫。 需求： 1 从【操作】表中，查找最后一行的数据，每一列 都为关键字 2 遍历这些关键字，从【总表】中查询这个关键字，把这一行后面的内容复制到 【预算】表中去 3 把【操作】中制定内容复制到【信息统计】中 Function Get操作NullLine() ' '从 操作表 获取最后一个有数据下面的空行 row 序号 ' Get操作NullLine = GetNullLine("操作", "A", 2) End Function Function Get预算NullLine() ' '从 预算表 获取最后一个有数据下面的空行 row 序号 ' Get预算NullLine = GetNullLine("预算", "A", 5) End Function Function Get信息统计NullLine() Get信息统计NullLine = GetNullLine("信息统计", "A", 2) End Function Function GetNullLine(excelTable As String, fromCell As String, beginRow As Integer) ' '从 excelTable表 获取[fromCell单元格开始的]最后一个无数据的空行 row 序号 ' '设置开始的行 Dim line: line = beginRow '选择Excel工作簿 Worksheets(excelTable).Select '查找空行 For Each c In Worksheets(excelTable).Range(fromCell & beginRow & ":" & fromCell & "999").Cells If c.Value "" Then 'With c.Font ' .Bold = True ' .Italic = True 'End With '''''''''MsgBox c.Value'查看当前是什么数据 Else '找到了空行则返回 GetNullLine = line Exit Function End If line = line + 1 Next c End Function Sub CreateNewOrderID() ' ' CreateNewOrderID 宏 ' 创建单号 ' Sheets("操作").Select Range("Q1:U1").Select '单元格格式为文本即可 Selection.NumberFormatLocal = "@" '设置单元格内容为 订单号，规则= 日期 ActiveCell.FormulaR1C1 = Year(Now()) & Month(Now()) & Day(Now()) & Hour(Now()) & Minute(Now()) & Second(Now()) End Sub ' '遍历 操作表 中的一行序号，每一个序号都进行 DealSelectData（str） 处理，失败，则提示 ' Function DealRowDatas(n As Integer) As Boolean DealRowDatas = False If n < 0 Then MsgBox "错误的参数 n=-1": Exit Function '判断传参错误 If Not DealSelectData(Worksheets("操作").Range("A" & n).Value) Then MsgBox "处理这行数据错误:【" & "A" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("B" & n).Value) Then MsgBox "处理这行数据错误:【" & "B" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("C" & n).Value) Then MsgBox "处理这行数据错误:【" & "C" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("D" & n).Value) Then MsgBox "处理这行数据错误:【" & "D" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("E" & n).Value) Then MsgBox "处理这行数据错误:【" & "E" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("F" & n).Value) Then MsgBox "处理这行数据错误:【" & "F" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("G" & n).Value) Then MsgBox "处理这行数据错误:【" & "G" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("H" & n).Value) Then MsgBox "处理这行数据错误:【" & "H" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("I" & n).Value) Then MsgBox "处理这行数据错误:【" & "I" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("J" & n).Value) Then MsgBox "处理这行数据错误:【" & "J" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("K" & n).Value) Then MsgBox "处理这行数据错误:【" & "K" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("L" & n).Value) Then MsgBox "处理这行数据错误:【" & "L" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("M" & n).Value) Then MsgBox "处理这行数据错误:【" & "M" & n & "】": Exit Function If Not DealSelectData(Worksheets("操作").Range("N" & n).Value) Then MsgBox "处理这行数据错误:【" & "N" & n & "】": Exit Function DealRowDatas = True End Function ' '根据一个字符串 比如 DM9 从总表 查询并拷贝到 预算表 中去 ' Function DealSelectData(str As String) As Boolean DealSelectData = False 'MsgBox "从总表中查询[" & str & "]并且添加到 预算表 中去" 'str= 'Range("A3").Select 'str= 'ActiveCell.FormulaR1C1 = "DM9" Sheets("总表").Select Dim findObj As Range Set findObj = Cells.Find(What:=str, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , MatchByte:=False, SearchFormat:=False) findObj.Activate findObj.Select 'MsgBox findObj.Column Dim findRow As Integer: findRow = findObj.Row '项目名称 辅材:元/单位 数量 人工:元/单位 数量 金额（元） 工艺做法及材料说明 '拷贝以上列数据 在总表中 B-H 列的数据 Range("B" & findRow & ":H" & findRow).Select Selection.Copy Sheets("预算").Select '从预算表中第几行开始粘贴 Dim targetRow: targetRow = Get预算NullLine() Range("A" & targetRow).Select ActiveSheet.Paste Sheets("操作").Select DealSelectData = True End Function Sub Copy操作To信息统计(fromStr As String, toStr As String) '从一个单元格拷贝到另一个单元格 Sheets("操作").Select Range(fromStr).Select 'MsgBox ActiveCell.Value'测试单元格是什么值 'ActiveCell.FormulaR1C1 = "2015215104319" ActiveCell.Copy 'Selection.Copy Sheets("信息统计").Select Range(toStr).Select 'ActiveSheet.Paste'此粘贴包含了格式，不好用！！！！！ '只粘贴值，不粘贴格式 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub ' '0 【增加到预算按钮】把操作表 最后一行的每一列的类似 DM9 这样的数据，从总表查询出来，拷贝到预算中去 ' Sub 增加到预算() Application.ScreenUpdating = False Call CreateNewOrderID If Not DealRowDatas(Get操作NullLine() - 1) Then: MsgBox "增加到预算 失败！有错误，请联系管理员 ": Application.ScreenUpdating = True: Exit Sub Sheets("预算").Select Application.ScreenUpdating = True Exit Sub End Sub ' ' 1 【保存到信息统计中】 ' Sub 保存到信息统计() Application.ScreenUpdating = False Dim emptyLineNo: emptyLineNo = Get信息统计NullLine() '单号 Call Copy操作To信息统计("Q1:U1", "A" & emptyLineNo) '预算员 Call Copy操作To信息统计("Q6:U6", "B" & emptyLineNo) '业主姓名 Call Copy操作To信息统计("Q2:U2", "C" & emptyLineNo) '联系方式 Call Copy操作To信息统计("Q3:U3", "D" & emptyLineNo) '家庭地址 Call Copy操作To信息统计("Q4:U4", "E" & emptyLineNo) '施工地址 Call Copy操作To信息统计("Q5:U5", "F" & emptyLineNo) Sheets("操作").Select Application.CutCopyMode = False Sheets("信息统计").Select Application.ScreenUpdating = True Exit Sub End Sub
转载请注明出处：http://www.cnblogs.com/ayanmw 多谢 ------------------------------------------------------------------------------------------------ 一定要专业!本博客定位于 ,C语言,C++语言,Java语言,Android开发和少量的Web开发,之前是做Web开发的，其实就是ASP维护，发现EasyASP这个好框架，对前端后端数据库 都很感觉亲切啊。. linux，总之后台开发多一点。以后也愿意学习 cocos2d-x 游戏客户端的开发。 |
今日新闻 |
点击排行 |
|
推荐新闻 |
图片新闻 |
|
专题文章 |
| CopyRight 2018-2019 实验室设备网 版权所有 win10的实时保护怎么永久关闭 |