|
发表于 2011-1-11 19:46
|
显示全部楼层
本楼为最佳答案
本帖最后由 爱疯 于 2011-1-11 19:47 编辑
Sub J4_1data()
Dim MyPath As String, MyFile As String, M As Long, Row1 As Long, LotNo As Long
Dim Arr1(), y
Dim XLapp As New Excel.Application
Dim Xlbook As Excel.Workbook
Dim Xlsheet As Excel.Worksheet
Application.ScreenUpdating = False
Sheets(2).Range("E2:J65536").ClearContents
MyPath = ThisWorkbook.Path & "\J4-1data\*.CSV"
MyFile = Dir(MyPath)
Do
M = M + 1
ReDim Preserve Arr1(1 To M)
Arr1(M) = MyFile
MyFile = Dir
Loop Until MyFile = ""
For i = 1 To UBound(Arr1)
Set Xlbook = XLapp.Workbooks.Open(ThisWorkbook.Path & "\J4-1data\" & Arr1(i))
XLapp.Visible = False
With Xlbook.Sheets(1)
Row1 = .Range("A65536").End(xlUp).Row
ARR2 = .Range("T18:T" & Row1)
ARR3 = .Range("K18:K" & Row1)
ARR4 = .Range("U18:U" & Row1)
ARR5 = .Range("V18:V" & Row1)
ARR6 = .Range("X18:X" & Row1)
ARR7 = .Range("AB18:AB" & Row1)
ARR8 = .Range("A5:A5")
End With
Xlbook.Close False
Set XLapp = Nothing
If i = 1 Then
Row2 = 2
Else
Row2 = Sheets(2).Range("E65536").End(xlUp).Row
End If
Sheets(2).Range("E" & Row2).Resize(UBound(ARR2), 1) = ARR2
Sheets(2).Range("F" & Row2).Resize(UBound(ARR3), 1) = ARR3
Sheets(2).Range("G" & Row2).Resize(UBound(ARR4), 1) = ARR4
Sheets(2).Range("H" & Row2).Resize(UBound(ARR5), 1) = ARR5
Sheets(2).Range("I" & Row2).Resize(UBound(ARR6), 1) = ARR6
Sheets(2).Range("J" & Row2).Resize(UBound(ARR7), 1) = ARR7
Sheet2.Cells(2, 12).Value = ARR8
Next i
MsgBox "提取完成"
Application.ScreenUpdating = True
End Sub
|
评分
-
查看全部评分
|