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