如何利用VBA代码 将三张表的数据读取到总表来
如何利用VBA代码 将三张表的数据读取到总表来A表
下单日期 客户 联系人 单号+产品名称+经营项目+日期 文案/摄影 设计/制作 改版拼版 出片 打样 规格(cm) 备注实印数 单价 数量 总金额 出错金额 何错
2011-3-26 福田 陈英 001-DN360正常印刷 50 20 60 80 20 21x28.5 3000 0.2 3000 830 20 字错
2011-3-26 福田 张燕林 001-DN360正常印刷 60 20 60 80 20 21x28.5 50000 0.1 50000 5240 100 字错
B表
下单日期 客户 联系人 单号+产品名称+经营项目+日期 文案/摄影 设计/制作 改版拼版 出片 打样 规格(cm) 备注实印数 单价 数量 总金额 出错金额 何错
2011-3-26 顺邦 小谢 001-DN360正常印刷 50 20 60 80 20 21x28.5 20 5 50 480 20 字错
2011-3-26 南湖 张总 55-喷绘 60 21x28.5 50000 20 50 1060 100 字错
C表
下单日期 客户 联系人 单号+产品名称+经营项目+日期 文案/摄影 设计/制作 改版拼版 出片 打样 规格(cm) 备注实印数 单价 数量 总金额 出错金额 何错
2011-3-26 顺邦 小谢 001-DN360正常印刷 50 20 60 80 20 21x28.5 20 5 50 480 20 字错
2011-3-26 南湖 张总 55-喷绘 60 21x28.5 50000 20 50 1060 100 字错
总表
下单日期 客户 联系人 单号+产品名称+经营项目+日期 文案/摄影 设计/制作 改版拼版 出片 打样 规格(cm) 备注实印数 单价 数量 总金额 出错金额 何错
2011-3-26 顺邦 小谢 001-DN360正常印刷 50 20 60 80 20 21x28.5 20 5 50 480 20 字错
2011-3-26 南湖 张总 55-喷绘 60 21x28.5 50000 20 50 1060 100 字错
然后在总表中添加个刷新按钮，只要三张表有添加新数据的话，总表可以实时刷新。。。。。。
(因三张表的表头都一样，所以不要求将表头也读取进来) --------------------编程问答-------------------- 自己试着慢慢做，有疑问的地方提出来，不要妄想让别人免费给你干活 --------------------编程问答-------------------- --------------------编程问答-------------------- '正好早几天做过类似的,不过是用VB做的,VBA应该更简单,具体属性录制宏就行
'下面工程 Command1:提取数据 Command2:打开目录 Command3:移除list框全部内容 Command4:关闭
'Command5:移除list选中项 wjs:文件数Label Text1:当前路径 list1:文件列表框
'本示例是将 各个文件的工作表加到 目标工作薄作为单独的工作表,要把3个表都放在目标工作薄的一个表中,需要对粘贴的起始位置再稍加处理
'运行程序时,将文件拖放到list1列表框即可,然后点Command1提取
Dim t1, t2 '定义计时变量
Dim ExcelApp As Object 'Excel程序对象
Dim SourceBook As Object '源 工作薄
Dim DesBook As Object '目标 工作薄
Dim ExcelSheet As Object '工作表
Private Sub Command1_Click()
' On Error GoTo Errh
If List1.ListCount > 0 Then
Dim filenames As String
Dim i As Integer, m As Integer '循环变量
Dim StartRow As Integer '开始行号
Dim EndRow As Integer '结束行号
t1 = Time '开始时间
'Set ExcelApp = GetObject(, "Excel.Application")
If ExcelApp Is Nothing Then Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.DisplayAlerts = False '关闭警告
'ExcelApp.AskToUpdateLinks = False '关闭工作表数据更新
ExcelApp.SheetsInNewWorkbook =wjs.caption '默认工作表的个数=文件数
Set DesBook = ExcelApp.Workbooks.Add '新建目标工作薄
Screen.MousePointer = 11
For i = 0 To List1.ListCount - 1
If ExcelApp Is Nothing Then
Set ExcelApp = CreateObject("Excel.Application")
Set SourceBook = ExcelApp.Workbooks.Open(List1.List(i)) '打开源工作薄
Else
If SourceBook Is Nothing Then Set SourceBook = ExcelApp.Workbooks.Open(List1.List(i))
End If
Set ExcelSheet = SourceBook.Worksheets("sheet1") '设定当前要复制的工作表
filenames = ExcelSheet.Name '作为新的工作薄的文件名
StartRow=2 '开始行
EndRow=3 '结束行
ExcelSheet.range("A" & StartRow & ":F" & EndRow).Copy '如复制范围A2-F3,自己修改成实际行列
DesBook.sheets(i+1).Paste '粘贴
'ExcelSheet.cells.EntireColumn.AutoFit '单元格自动列宽
Set ExcelSheet = DesBook.Worksheets(1)
DesBook.sheets(i+1).cells.EntireColumn.AutoFit
SourceBook.Close
Set SourceBook = Nothing
Next '添加文件结束
DesBook.SaveAs App.Path & "\" & filenames & "数据.xls" '保存工作薄
ExcelApp.Quit
Set ExcelApp = Nothing
Screen.MousePointer = 0
t2 = Time
MsgBox "统计完成，耗时" & DateDiff("s", t1, t2) & "秒", 64, "提示"
End If
'Errh:
' If Err.Number = 429 Or Err.Number = 9 Then
' Resume Next
' End If
End Sub
Private Sub Command2_Click()
Shell "explorer.exe " & Text1.Text & "", vbNormalFocus '打开目录
End Sub
Private Sub Command3_Click()
List1.Clear
wjs.Caption = 0
End Sub
Private Sub Command4_Click()
Unload Me
End Sub
Private Sub Command5_Click()
If List1.ListIndex = -1 Then
MsgBox "你当前没有选择要移除的文件！", 16, "提示"
List1.SetFocus
Exit Sub
End If
List1.RemoveItem List1.ListIndex '移除选中项
wjs.Caption = List1.ListCount
End Sub
Private Sub Form_Load()
Text1.Text = App.Path
End Sub
Private Sub List1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To Data.Files.Count
List1.AddItem Data.Files(i)
Next
wjs.Caption = Data.Files.Count '文件总个数
End Sub --------------------编程问答-------------------- DesBook.sheets(i+1).Paste '粘贴
换成下面,就可以在上次粘贴的后面接着粘贴
DesBook.sheets(1).Activate
ExcelSheet.Cells(Rs * i + 1, 1).Select '使excel的单元格获得焦点,作为下次粘贴的起始位置
DesBook.sheets(1).Paste '粘贴
补充：VB , VBA
