为何处理不到文件夹内的其他工作簿

zdh8083

各位大神：
        不知道为啥套用了一个代码只能处理文件夹中的一个工作簿，其他的都没反应，求大神帮忙完善一下，谢谢。
        另外如果可以的话，顺便帮忙优化一下代码 ： 原始导出的数据都是文本格式，需要将带“日期”字段的格式设置为“YYYY-MM-DD”格式，带数字的列转换为数值格式，“证件号码“及其他文字性的那些列可以忽略处理。

Sub 数据处理()
    Application.ScreenUpdating = False
    Dim FileName As String, ARR, I, CSRQ, GZRQ, RSRQ, ZJHM
    FileName = Dir(ThisWorkbook.Path & "\*.xls*")
        If FileName <> ThisWorkbook.Name Then
            Fn = ThisWorkbook.Path & "\" & FileName
            Workbooks.Open (Fn)
            Worksheets(1).Select
            CSRQ = Range("1:1").Find("出生日期").Column
            Columns(CSRQ).NumberFormatLocal = " YYYY-MM-DD"
            GZRQ = Range("1:1").Find("参加工作日期").Column
            Columns(GZRQ).NumberFormatLocal = " YYYY-MM-DD"
            RSRQ = Range("1:1").Find("入司日期").Column
            Columns(RSRQ).NumberFormatLocal = " YYYY-MM-DD"
            ZJHM = Range("1:1").Find("证件号码").Column
            Columns(ZJHM).NumberFormatLocal = " @"
            ARR = [A1].CurrentRegion
            For I = 2 To Range("A1").End(xlDown).Row
                For J = 1 To Range("A1").End(xlToRight).Column
                    If J <> CSRQ And J <> GZRQ And J <> RSRQ And J <> ZJHM And J <> Range("1:1").Find("部门").Column And J <> Range("1:1").Find("姓名").Column Then
                        ARR(I, J) = Val(Cells(I, J))
                    End If
                Next
            Next
            [A1].Resize(I - 1, J - 1) = ARR

            Workbooks(Fn).Close True
        End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

ykcbf1100

要加一个工作簿循环代码的。

limonet

            Workbooks(Fn).Close True
        End If
加一句：FileName = Dir

zdh8083

ykcbf1100 发表于 2022-12-19 12:36
要加一个工作簿循环代码的。

哦。。。漏了一段，感谢

tmplinshi

练习

1. Sub 数据处理()
   
2.     Application.ScreenUpdating = False
   
3. 
   
4.     Dim fPath
   
5.    
   
6.     For Each fPath In FileList(ThisWorkbook.Path & "\*.xls?")
   
7.         If fPath <> ThisWorkbook.FullName Then
   
8.             ModifyFile CStr(fPath)
   
9.         End If
   
10.     Next
    
11. 
    
12.     Application.CutCopyMode = False
    
13.     Application.ScreenUpdating = True
    
14. End Sub
    
15. 
    
16. Sub ModifyFile(fPath As String)
    
17. 
    
18.     With Workbooks.Open(fPath)
    
19.         .Sheets(1).Select
    
20. 
    
21.         Call 设置单元格格式
    
22.         Call 带数字的列转换为数值格式
    
23. 
    
24.         .Close True
    
25.     End With
    
26.    
    
27. End Sub
    
28. 
    
29. Sub 设置单元格格式()
    
30.     Dim str
    
31.     For Each str In Array("出生日期", "参加工作日期", "入司日期")
    
32.         Range("1:1").Find(str).EntireColumn.NumberFormatLocal = " YYYY-MM-DD"
    
33.     Next
    
34. 
    
35.     Range("1:1").Find("证件号码").EntireColumn.NumberFormatLocal = " @"
    
36. End Sub
    
37. 
    
38. Sub 带数字的列转换为数值格式()
    
39.     Dim ARR, I, J, skipColumns
    
40. 
    
41.     ARR = [A1].CurrentRegion
    
42.     Set skipColumns = GetExcludeColumns("出生日期", "参加工作日期", "入司日期", "证件号码", "部门", "姓名")
    
43. 
    
44.     For I = 2 To Range("A1").End(xlDown).Row
    
45.         For J = 1 To Range("A1").End(xlToRight).Column
    
46.             If Not skipColumns.Exists(J) Then
    
47.                 ARR(I, J) = Val(Cells(I, J))
    
48.             End If
    
49.         Next
    
50.     Next
    
51. 
    
52.     [A1].Resize(I - 1, J - 1) = ARR
    
53. End Sub
    
54. 
    
55. Function GetExcludeColumns(ParamArray cellKeywords()) As Object
    
56.     Dim dict As Object
    
57.     Set dict = CreateObject("Scripting.Dictionary")
    
58. 
    
59.     Dim str, col
    
60.     For Each str In cellKeywords
    
61.         col = Range("1:1").Find(str).Column
    
62.         dict(col) = ""
    
63.     Next
    
64.    
    
65.     Set GetExcludeColumns = dict
    
66. End Function
    
67. 
    
68. Function FileList(filePattern As String) As Collection
    
69. 
    
70.     Dim coll  As New Collection
    
71.     Dim fso   As Object
    
72.     Dim fDir  As String
    
73.     Dim fName As String
    
74.    
    
75.     fName = Dir(filePattern)
    
76.     If (fName = "") Then Exit Function
    
77.    
    
78.     Set fso = CreateObject("Scripting.FilesystemObject")
    
79.     fDir = fso.GetParentFolderName(filePattern) & ""
    
80. 
    
81.     Do
    
82.         coll.Add fDir & fName
    
83.         fName = Dir()
    
84.     Loop Until (fName = "")
    
85. 
    
86.     Set FileList = coll
    
87.    
    
88. End Function
    

复制代码

注：论坛原因，代码第 79 行有一个反斜杠符号没有显示出来。正确的应该是：

gwjkkkkk

Sub TEST()
    Dim strFileName$, strPath$, wkb As Workbook, arr, i&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xlsx")
   
    Do Until strFileName = ""
           Set wkb = Workbooks.Open(strPath & strFileName)
               dic.RemoveAll
               With wkb.Sheets(1)
                  arr = .[A1].CurrentRegion
                  .[A1].CurrentRegion.Offset(1).Clear
                  .Columns(5).NumberFormatLocal = "@"
                  For i = 1 To UBound(arr, 2)
                     If InStr(arr(1, i), "日期") Then
                        dic(arr(1, i)) = "yyyy/mm/dd"
                     End If
                  Next i
                  With .[A1].CurrentRegion.Resize(UBound(arr), UBound(arr, 2))
                      For i = 1 To UBound(arr, 2)
                          If dic.exists(arr(1, i)) Then .Columns(i).NumberFormatLocal = dic(arr(1, i))
                      Next i
                      .Value = arr
                      .HorizontalAlignment = xlCenter
                      .Borders.LineStyle = xlContinuous
                     .Rows(1).Font.Bold = True
                     .EntireColumn.AutoFit
                     .EntireRow.AutoFit
                  End With
               End With
           wkb.Close True
        strFileName = Dir
    Loop
   
    Set wkb = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

zdh8083

gwjkkkkk 发表于 2022-12-19 19:19
Sub TEST()
    Dim strFileName$, strPath$, wkb As Workbook, arr, i&
   

大神好，假设有些表，没有“日期”字段的，就会出现报错，怎么加一句让它继续执行后面的代码？

tanglf188

zdh8083 发表于 2023-1-3 13:48
大神好，假设有些表，没有“日期”字段的，就会出现报错，怎么加一句让它继续执行后面的代码？

加在开头部分：On Error Resume Next

zdh8083

tanglf188 发表于 2023-1-3 14:15
加在开头部分：On Error Resume Next

是不是在没有相应字段的情况下，运行的时间会大幅度增加？ 本来几秒搞定的愣是运行了两分多钟。。。。