Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3255|回复: 5

[已解决]数据读取

[复制链接]
发表于 2011-1-11 17:22 | 显示全部楼层 |阅读模式
提示: 作者被禁止或删除 内容自动屏蔽
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 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

评分

参与人数 1 +20 收起 理由
amulee + 20 最佳奖励

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2011-1-12 07:47 | 显示全部楼层
提示: 作者被禁止或删除 内容自动屏蔽
回复

使用道具 举报

发表于 2011-1-12 12:16 | 显示全部楼层
学习学习!!!!
回复

使用道具 举报

发表于 2014-2-28 22:56 | 显示全部楼层
真看不懂
回复

使用道具 举报

发表于 2016-4-2 15:43 | 显示全部楼层
学习
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 01:48 , Processed in 0.508891 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表