[已解决]如何查询这种列数据？

阿柔 · 发表于 2014-5-4 08:15

本帖最后由阿柔于 2014-5-4 10:18 编辑

附件

查询列数据.rar (351.83 KB, 下载次数: 13)

grf1973 · 发表于 2014-5-4 09:54

Sub test()
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path)
For Each fff In ff.subfolders
col = Replace(fff, ff & "", "")
For Each f In fff.Files
r = Val(Replace(f, fff & "", ""))
Workbooks.Open f
n = ActiveWorkbook.Sheets(1).UsedRange.Columns.Count
If n = 1 Then If Application.WorksheetFunction.CountA(ActiveWorkbook.Sheets(1).Range("a:a")) = 0 Then n = 0
ActiveWorkbook.Close False
Cells(r, col) = n
Next
Next
End Sub

复制代码

grf1973 · 发表于 2014-5-4 09:57

加上注释。

Sub test()
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path) '取得当前文件夹名
For Each fff In ff.subfolders 'fff为当前文件夹下所有子文件夹名（全路径）
col = Replace(fff, ff & "", "") '子文件夹名（列号）
For Each f In fff.Files 'f为当前子文件夹下所有文件名（全路径）
r = Val(Replace(f, fff & "", "")) '文件名（行号）
Workbooks.Open f
n = ActiveWorkbook.Sheets(1).UsedRange.Columns.Count '文件中列数
If n = 1 Then If Application.WorksheetFunction.CountA(ActiveWorkbook.Sheets(1).Range("a:a")) = 0 Then n = 0 '把列数为0的情况找出来
ActiveWorkbook.Close False
Cells(r, col) = n
Next
Next
End Sub

复制代码

grf1973 · 发表于 2014-5-4 09:59

请看附件。

grf1973 · 发表于 2014-5-4 10:25

更严谨一点应该是这样。。。。。。

Sub test()
Application.ScreenUpdating = False
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path) '取得当前文件夹名
For Each fff In ff.subfolders 'fff为当前文件夹下所有子文件夹名（全路径）
col = Replace(fff, ff & "", "") '子文件夹名（列号）
For Each f In fff.Files 'f为当前子文件夹下所有文件名（全路径）
r = Val(Replace(f, fff & "", "")) '文件名（行号）
Workbooks.Open f
Set sh = ActiveWorkbook.Sheets(1)
n = 0
mc = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column '最大列数
For i = 1 To mc
If Application.WorksheetFunction.CountA(sh.Columns(i)) > 0 Then n = n + 1 '把非空列找出来
Next
ActiveWorkbook.Close False
Cells(r, col) = n
Next
Next
Application.ScreenUpdating = True
End Sub

复制代码

		自动登录	找回密码
密码			注册