VB6实现Excel多工作簿数据合并
Posted ryueifu-vba
tags:
篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了VB6实现Excel多工作簿数据合并相关的知识,希望对你有一定的参考价值。
以前的同事,工作需要,让我帮忙完成多个工作簿的汇总。
我就用最熟悉的VB6写了一个Form应用程序,这是因为我不知道她目前的系统和Office情况,如果太高大上了,她不会部署安装。索性就简单粗暴地来个桌面App。
App的操作效果:
程序源代码:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private f As Variant Private i As Integer, j As Integer Private ExcelApp As Excel.Application Private wbk As Excel.Workbook, wbk2 As Excel.Workbook Private wst As Excel.Worksheet, wst2 As Excel.Worksheet Private rg As Excel.Range, rg2 As Excel.Range Private arr() As Variant Private Sub Command1_Click() On Error GoTo Err1 If Me.List1.ListCount = 0 Or Me.Text1.Text = "" Or Me.Text2.Text = "" Then MsgBox "不满足合并条件,请确认各项,然后重试。", vbExclamation Exit Sub End If Set ExcelApp = CreateObject("Excel.Application") With ExcelApp .Visible = True .WindowState = xlMaximized Set wbk2 = .Workbooks.Add Set wst2 = wbk2.Worksheets(1) For i = 0 To Me.List1.ListCount - 1 Me.List1.ListIndex = i f = Me.List1.List(i) If Dir(f) <> "" Then Set wbk = .Workbooks.Open(FileName:=f, UpdateLinks:=False) Set wst = wbk.Worksheets(Me.Text1.Text) Set rg = wst.Range(Me.Text2.Text) ReDim arr(1 To rg.Cells.Count) j = 0 For Each rg2 In rg j = j + 1 arr(j) = rg2.Value Next rg2 wst2.Cells(i + 2, "A").Resize(, UBound(arr)).Value = arr wbk.Close False End If Next i wst2.UsedRange.EntireColumn.AutoFit End With Exit Sub Err1: MsgBox Err.Description, vbCritical End Sub
如果要下载工具,请加QQ群:61840693,去群文件下载。
以上是关于VB6实现Excel多工作簿数据合并的主要内容,如果未能解决你的问题,请参考以下文章