[已解决]解释正则表达式？

sdfsdfs

'说明：文件名排序需要用到工作表Sheet3，请确保该工作表存在且没有您存放的数据，不能锁定保护，也不能有合并单元格。请保持该工作表为原始状态！
Sub abc()
    Dim sz(), sz1, myRegExp As Object
    Set myRegExp = CreateObject("VBScript.RegExp")
    myRegExp.Global = True
    myRegExp.IgnoreCase = Ture
    myRegExp.Pattern = "[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]-[0-9][0-9]?.xls"
    s = Dir(ThisWorkbook.Path & "\*.xls")
    n = -1
    Do While s <> ""
        If UCase(s) Like "*[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]-[0-9]*.XLS" Then
            n = n + 1
            ReDim Preserve sz(n)
            sz(n) = s
        End If
        s = Dir
    Loop
    Set matchs = myRegExp.Execute(Join(sz, ","))
    If matchs.Count = 0 Then MsgBox "没有数据文件！", , "提示": GoTo out
    ReDim sz1(2, 0)
    For i = 0 To matchs.Count - 1
        ReDim Preserve sz1(2, i)
        sz1(0, i) = matchs.Item(i)
        sz1(1, i) = Left(matchs.Item(i), 10) '日期
        sz1(2, i) = Right(matchs.Item(i), Len(matchs.Item(i)) - 11) '序号
        sz1(2, i) = Left(sz1(2, i), Len(sz1(2, i)) - 4)           '序号
    Next i
    Application.ScreenUpdating = False
    Sheet3.Activate
    With Sheet3
    .Columns("A:C").ClearContents
    .[a1].Resize(UBound(sz1, 2) + 1, 3) = Application.Transpose(sz1)
    .[a1].CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("C1"), Order2:=xlAscending, Header:=xlGuess
    sz1 = Application.Transpose(.Range("A1:A" & .[a1].CurrentRegion.Rows.Count))
    .Columns("A:C").ClearContents
    End With
    For i = 1 To UBound(sz1)
        For ii = i - 1 To UBound(sz)
            If sz(ii) Like "*" & sz1(i) Then
                temp = sz(i - 1)
                sz(i - 1) = sz(ii)
                sz(ii) = temp
                Exit For
            End If
        Next ii
    Next i
   
    '数组sz已经排好了序
    Sheet1.Activate
    Columns("A:I").ClearContents
    For i = 0 To UBound(sz)
            With Workbooks.Open(ThisWorkbook.Path & "\" & sz(i))
                For ii = 1 To .Sheets(1).Range("A65536").End(3).Row
                    If ThisWorkbook.Sheets(1).Range("A65536").End(3).Row = 1 Then
                        W = 10
                    Else
                        W = 2
                    End If
                    If .Sheets(1).Range("H" & ii) = "a" Then .Sheets(1).Rows(ii).Copy ThisWorkbook.Sheets(1).Range("A65536").End(3)(W)
                Next ii
                .Close False
            End With
    Next i
out:
    Application.ScreenUpdating = True
End Sub

最佳答案

月排行榜 / 总排行榜

danio112

2013-10-13 14:48

sdfsdfs 发表于 2013-10-13 14:03
能不能解释代码？

Sub abc()
    Dim sz(), sz1, myRegExp As Object
    Set myRegExp = CreateObject("VBScript.RegExp")
    myRegExp.Global = True
    myRegExp.IgnoreCase = Ture
    myRegExp.Pattern = "[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]-[0-9][0-9]?.xls" '正则表达式查询为0000-00-00-00(或少一个0),以xls结尾。
    s = Dir(ThisWorkbook.Path & "\*.xls")　'取路径
    n = -1
    Do While s <> "" 　遍历所有的xls文档
        If UCase(s) Like "*[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]-[0-9]*.XLS" Then '文档名包含0000-00-00-0格式的文档
            n = n + 1
            ReDim Preserve sz(n)
            sz(n) = s　'把文档名依次放入数组中
        End If
        s = Dir
    Loop
    Set matchs = myRegExp.Execute(Join(sz, ","))　'把包含文档名的数组用逗号串接起来执行正则表达式查询
    If matchs.Count = 0 Then MsgBox "没有数据文件！", , "提示": GoTo out　'没查到就退出
    ReDim sz1(2, 0)
    For i = 0 To matchs.Count - 1　'循环所有查到符合条件的项目
        ReDim Preserve sz1(2, i)
        sz1(0, i) = matchs.Item(i)　'sz(0,i)保存项目
        sz1(1, i) = Left(matchs.Item(i), 10) '日期　'sz(1,i)保存项目前10个字符，即0000-00-00
        sz1(2, i) = Right(matchs.Item(i), Len(matchs.Item(i)) - 11) '序号 'sz(2,i)保存除掉前10个字符剩余的部份
        sz1(2, i) = Left(sz1(2, i), Len(sz1(2, i)) - 4)           '序号　'再把sz(2,i)换成保存左掉右边4个字符的全部字符
    Next i
    Application.ScreenUpdating = False
    Sheet3.Activate
    With Sheet3
    .Columns("A:C").ClearContents
    .[a1].Resize(UBound(sz1, 2) + 1, 3) = Application.Transpose(sz1)　'把sz1数组的内容全部写入到a,b,c三列
    .[a1].CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("C1"), Order2:=xlAscending, Header:=xlGuess　'排序，b列升序，c列升序
    sz1 = Application.Transpose(.Range("A1:A" & .[a1].CurrentRegion.Rows.Count)) 'A列转置成一维数组
    .Columns("A:C").ClearContents
    End With
    For i = 1 To UBound(sz1)
        For ii = i - 1 To UBound(sz)
            If sz(ii) Like "*" & sz1(i) Then　'如果前一个包含后一个，则交换顺序，重新排序
                temp = sz(i - 1)
                sz(i - 1) = sz(ii)
                sz(ii) = temp
                Exit For
            End If
        Next ii
    Next i
   
    '数组sz已经排好了序
    Sheet1.Activate
    Columns("A:I").ClearContents
    For i = 0 To UBound(sz)　'遍历该路径下所有的xls文档
            With Workbooks.Open(ThisWorkbook.Path & "\" & sz(i))
                For ii = 1 To .Sheets(1).Range("A65536").End(3).Row '遍历所有行
                    If ThisWorkbook.Sheets(1).Range("A65536").End(3).Row = 1 Then
                        W = 10　'1行w=10
                    Else
                        W = 2
                    End If
                    If .Sheets(1).Range("H" & ii) = "a" Then .Sheets(1).Rows(ii).Copy ThisWorkbook.Sheets(1).Range("A65536").End(3)(W) 'Hii为a, 则该行复制当前工作薄的sheet1最后一行的下一行（w=2), 或最后一行的下9行（w=10)
                Next ii
                .Close False
            End With
    Next i
out:
    Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

danio112

解释正则表达式还是程序？

sdfsdfs

danio112 发表于 2013-10-10 21:50
解释正则表达式还是程序？

能不能解释代码？

danio112

sdfsdfs 发表于 2013-10-13 14:03
能不能解释代码？

Sub abc()
    Dim sz(), sz1, myRegExp As Object
    Set myRegExp = CreateObject("VBScript.RegExp")
    myRegExp.Global = True
    myRegExp.IgnoreCase = Ture
    myRegExp.Pattern = "[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]-[0-9][0-9]?.xls" '正则表达式查询为0000-00-00-00(或少一个0),以xls结尾。
    s = Dir(ThisWorkbook.Path & "\*.xls")　'取路径
    n = -1
    Do While s <> "" 　遍历所有的xls文档
        If UCase(s) Like "*[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]-[0-9]*.XLS" Then '文档名包含0000-00-00-0格式的文档
            n = n + 1
            ReDim Preserve sz(n)
            sz(n) = s　'把文档名依次放入数组中
        End If
        s = Dir
    Loop
    Set matchs = myRegExp.Execute(Join(sz, ","))　'把包含文档名的数组用逗号串接起来执行正则表达式查询
    If matchs.Count = 0 Then MsgBox "没有数据文件！", , "提示": GoTo out　'没查到就退出
    ReDim sz1(2, 0)
    For i = 0 To matchs.Count - 1　'循环所有查到符合条件的项目
        ReDim Preserve sz1(2, i)
        sz1(0, i) = matchs.Item(i)　'sz(0,i)保存项目
        sz1(1, i) = Left(matchs.Item(i), 10) '日期　'sz(1,i)保存项目前10个字符，即0000-00-00
        sz1(2, i) = Right(matchs.Item(i), Len(matchs.Item(i)) - 11) '序号 'sz(2,i)保存除掉前10个字符剩余的部份
        sz1(2, i) = Left(sz1(2, i), Len(sz1(2, i)) - 4)           '序号　'再把sz(2,i)换成保存左掉右边4个字符的全部字符
    Next i
    Application.ScreenUpdating = False
    Sheet3.Activate
    With Sheet3
    .Columns("A:C").ClearContents
    .[a1].Resize(UBound(sz1, 2) + 1, 3) = Application.Transpose(sz1)　'把sz1数组的内容全部写入到a,b,c三列
    .[a1].CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("C1"), Order2:=xlAscending, Header:=xlGuess　'排序，b列升序，c列升序
    sz1 = Application.Transpose(.Range("A1:A" & .[a1].CurrentRegion.Rows.Count)) 'A列转置成一维数组
    .Columns("A:C").ClearContents
    End With
    For i = 1 To UBound(sz1)
        For ii = i - 1 To UBound(sz)
            If sz(ii) Like "*" & sz1(i) Then　'如果前一个包含后一个，则交换顺序，重新排序
                temp = sz(i - 1)
                sz(i - 1) = sz(ii)
                sz(ii) = temp
                Exit For
            End If
        Next ii
    Next i
   
    '数组sz已经排好了序
    Sheet1.Activate
    Columns("A:I").ClearContents
    For i = 0 To UBound(sz)　'遍历该路径下所有的xls文档
            With Workbooks.Open(ThisWorkbook.Path & "\" & sz(i))
                For ii = 1 To .Sheets(1).Range("A65536").End(3).Row '遍历所有行
                    If ThisWorkbook.Sheets(1).Range("A65536").End(3).Row = 1 Then
                        W = 10　'1行w=10
                    Else
                        W = 2
                    End If
                    If .Sheets(1).Range("H" & ii) = "a" Then .Sheets(1).Rows(ii).Copy ThisWorkbook.Sheets(1).Range("A65536").End(3)(W) 'Hii为a, 则该行复制当前工作薄的sheet1最后一行的下一行（w=2), 或最后一行的下9行（w=10)
                Next ii
                .Close False
            End With
    Next i
out:
    Application.ScreenUpdating = True
End Sub