找个人，写个vba

secowu

1、遍历指定目录下的xls文件，

2、将完整路径名写在A列，

3、将读取文件的第一个工作表的第一行内容写在B列以后

2012hongrui

前两点很简单呀，用dir就能做到，设置一个动态数组进行记录，只是不知道第3点是啥子意思。

secowu

就是在一个新建的excel文件里，A列写完整的文件名，B列后从读取的xls文件的第一个工作表里的第一行提取数据

2012hongrui

今天下午刚好有空，编好了，拿去吧！

适用于EXCEL2003，这个版本是事实工业标准.

1.把所有的EXCEL工作表放到D:\EXCEL目录中，随便打开一个EXCEL工作表，常用工具栏多出了一个“统计”按扭，运行多生成出来的统计按扭，一切搞定。

2.要修改默认目录“D:\EXCEL”，请用winhex打开DLL文件，在00002684处开始修改，预留了几十个空字符位置，相信也没得这么长的路径吧！

secowu

原帖由 <i>2012hongrui</i> 于 2012-12-11 15:17 发表 <a href="http://bbs.wuyou.net/redirect.php?goto=findpost&pid=2635339&ptid=273161" target="_blank"><img src="http://bbs.wuyou.net/images/common/back.gif" border="0" onload="if(this.width>screen.width*0.7) {this.resized=true; this.width=screen.width*0.7; this.alt='Click here to open new window\nCTRL+Mouse wheel to zoom in/out';}" onmouseover="if(this.width>screen.width*0.7) {this.resized=true; this.width=screen.width*0.7; this.style.cursor='hand'; this.alt='Click here to open new window\nCTRL+Mouse wheel to zoom in/out';}" onclick="if(!this.resized) {return true;} else {window.open(this.src);}" onmousewheel="return imgzoom(this);" alt="" /></a><br />
今天下午刚好有空，编好了，拿去吧！<br />
<br />
适用于EXCEL2003，这个版本是事实工业标准.<br />
<br />
1.把所有的EXCEL工作表放到D:\EXCEL目录中，随便打开一个EXCEL工作表，常用工具栏多出了一个“统计”按扭，运行多生成出来 ...

<br />

1、感谢兄弟，我用的是2013版本，加载项及用你的安装脚本安装不了。
能否做个2013的呢》
2、另外，是否可以将那个路径用个文件夹选取的文件，而不用固定死呢，呵呵 。
谢谢啦。

secowu

3、如果还能用变量的定义指定读取第几个工作表的第几行或者第几列内容，就相当实用灵活了。呵呵 。

2012hongrui

楼主的要求真高，得寸进尺，好吧，又编译好了一个，EXCEL2003、EXCEL2007用过没问题，EXCEL2013没用过，试试吧！拿去哟！！！

[ 本帖最后由 2012hongrui 于 2012-12-12 11:16 编辑 ]

secowu

原帖由 <i>2012hongrui</i> 于 2012-12-12 11:10 发表 <a href="http://bbs.wuyou.net/redirect.php?goto=findpost&pid=2635845&ptid=273161" target="_blank"><img src="http://bbs.wuyou.net/images/common/back.gif" border="0" onload="if(this.width>screen.width*0.7) {this.resized=true; this.width=screen.width*0.7; this.alt='Click here to open new window\nCTRL+Mouse wheel to zoom in/out';}" onmouseover="if(this.width>screen.width*0.7) {this.resized=true; this.width=screen.width*0.7; this.style.cursor='hand'; this.alt='Click here to open new window\nCTRL+Mouse wheel to zoom in/out';}" onclick="if(!this.resized) {return true;} else {window.open(this.src);}" onmousewheel="return imgzoom(this);" alt="" /></a><br />
楼主的要求真高，得寸进尺，好吧，又编译好了一个，EXCEL2003、EXCEL2007用过没问题，EXCEL2013没用过，试试吧！拿去哟！！！

<br />
感谢高手，拔刀相助。
盖世神功，多子多福。

secowu

Sub Filelist()
    Dim Fso As Object, sFileType$, strPath$, i&, j&, lc&, arrf$(), mf&, arr, brr()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = True
        If .Show Then
            strPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Set Fso = CreateObject("Scripting.FileSystemObject")
    If Application.Version <= 11 Then sFileType = "*.xls" Else sFileType = "*.xls*"
    Call searchFile(strPath, sFileType, Fso, arrf, mf)
    If mf Then
        ReDim brr(1 To mf, -1 To 254)
        For i = 1 To mf
            brr(i, -1) = arrf(1, i)
            brr(i, 0) = arrf(2, i)
            With GetObject(arrf(1, i) & "\" & arrf(2, i))
                With .Sheets(1)
                    arr = .Range("a1", .Cells(1, .Columns.Count).End(1))
                End With
                .Close False
            End With
            For j = 1 To UBound(arr, 2)
                brr(i, j) = arr(1, j)
            Next
            If j > lc Then lc = j
        Next
    End If
    Cells.Clear
    [a1].Resize(mf, lc + 1) = brr
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

Private Sub searchFile(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
    Dim Folder As Object
    Dim SubFolder As Object
    Dim File As Object
    Set Folder = Fso.GetFolder(sPath)
    For Each File In Folder.Files
        If File.Name Like sFileType Then
            If File.Name <> ThisWorkbook.Name Then
                mf = mf + 1
                ReDim Preserve arrf(1 To 2, 1 To mf)
                arrf(1, mf) = sPath
                arrf(2, mf) = File.Name
            End If
        End If
    Next
    If Folder.SubFolders.Count > 0 Then
        For Each SubFolder In Folder.SubFolders
            Call searchFile(SubFolder.Path, sFileType, Fso, arrf, mf)
        Next
    End If
    Set Folder = Nothing
    Set File = Nothing
    Set SubFolder = Nothing
End Sub

secowu

可能我的是windows 2012 x63的问题，dll注册不成功。
等下整个VM试下XP，谢谢

[Window Title]
RegSvr32

[Content]
模块“C:\WINDOWS\system32\EXCEL.DLL”加载失败。

请确保该二进制存储在指定的路径中，或者调试它以检查该二进制或相关的 .DLL 文件是否有问题。

找不到指定的模块。


[确定]

2012hongrui

方法其实很简单，把原来的RAMDISK.VDF再复制一个为RAMBOOT.VDF,这个RAMBOOT.VDF是连续的，里面的SYSTEM注册表文件是关机不保存的。如果说是XP,这个RAMBOOT.VDF是可以精简到只有一些启动文件。WIN7暂时不知道如何精简，就用一样的了。用如下的菜单启动就行了：

map (hd0,4)/ramboot.vdf (hd0)
map (hd0) (hd1)
map --hook
rootnoverify (hd0,0)
chainloader (hd0,0)/ntldr

如果说是WINDOW7,把ntldr改成grldr就行了，保证是激活了的。

由于内存只有4g,做的是精简版的WIN7,文件只有2G。

具体请自行琢磨，无论是关机保存还是不保存，下次开机那个勾始终是去掉的。