无忧启动论坛

标题: 找个人，写个vba [打印本页]

作者: secowu 时间: 2012-12-10 14:08
标题: 找个人，写个vba
1、遍历指定目录下的xls文件，

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

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

作者: 2012hongrui 时间: 2012-12-10 17:26
前两点很简单呀，用dir就能做到，设置一个动态数组进行记录，只是不知道第3点是啥子意思。

作者: secowu 时间: 2012-12-10 18:29
标题: 回复 #2 2012hongrui 的帖子
就是在一个新建的excel文件里，A列写完整的文件名，B列后从读取的xls文件的第一个工作表里的第一行提取数据

作者: 2012hongrui 时间: 2012-12-11 15:17
今天下午刚好有空，编好了，拿去吧！

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

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

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

10.36 KB, 下载次数: 22, 下载积分: 无忧币 -2

作者: secowu 时间: 2012-12-11 19:04

原帖由 <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 时间: 2012-12-11 19:06
3、如果还能用变量的定义指定读取第几个工作表的第几行或者第几列内容，就相当实用灵活了。呵呵。

作者: 2012hongrui 时间: 2012-12-12 11:10
楼主的要求真高，得寸进尺，好吧，又编译好了一个，EXCEL2003、EXCEL2007用过没问题，EXCEL2013没用过，试试吧！拿去哟！！！

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

自定义目录EXCEL.7z

16.11 KB, 下载次数: 21, 下载积分: 无忧币 -2

作者: secowu 时间: 2012-12-12 12:44

原帖由 <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 时间: 2012-12-12 12:44
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 时间: 2012-12-12 12:48
可能我的是windows 2012 x63的问题，dll注册不成功。
等下整个VM试下XP，谢谢

[Window Title]
RegSvr32

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

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

找不到指定的模块。

[确定]

作者: 2012hongrui 时间: 2012-12-16 21:07
方法其实很简单，把原来的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。

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

欢迎光临无忧启动论坛 (http://wuyou.net./)

Powered by Discuz! X3.3