查看: 16  |  回复: 0
  VB6 实现Excel多工作簿数据合并
楼主
发表于 2025年3月30日 17:59
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


您需要登录后才可以回帖 登录 | 立即注册
【本版规则】请勿发表违反国家法律的内容,否则会被冻结账号和删贴。
用户名: 立即注册
密码:
2020-2025 MaNongKu.com