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，去群文件下載。