T = Timer
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists("New") Then FSO.CreateFolder("New")
For Each File in FSO.GetFolder(".").Files
   Ext = FSO.GetExtensionName(File)
   Name = FSO.GetBaseName(File)
   If LCase(Ext) = "txt" Then
      fDir = "New\" & Name
      If Not FSO.FolderExists(fDir) Then FSO.CreateFolder(fDir)
      Open_File FSO.OpenTextFile(File)
   End If
Next

MsgBox Timer - T

Sub Open_File(f)
   Do Until f.AtEndOfStream
      Text = f.ReadLine
      If RegEx(Text) <> "" Then GetStr Split(RegEx(Text)," ")
   Loop
End Sub

Sub GetStr(ar)
   Dim A(9)
   For i = 0 to 9 :A(i) = 0 :Next
   For i = 1 to UBound(ar) - 1
      For j = i + 1 to UBound(ar)
         s1 = Right(CInt(ar(i)) + CInt(ar(j)),1) :A(s1) = A(s1) + 1
         s2 = Right(CInt(ar(i)) - CInt(ar(j)),1) :A(s2) = A(s2) + 1
         s3 = Right(CInt(ar(i)) * CInt(ar(j)),1) :A(s3) = A(s3) + 1
      Next
   Next

   For i = 1 to 6
      For j = i + 1 to 7
         For k = j + 1 to 8
            For L = k + 1 to 9
               ReDim PreServe B(n)
               B(n) = A(i) + A(j) + A(k) + A(L) + A(0)
               n = n + 1
            Next
         Next
      Next
   Next

   n = 1
   For i = 1 to UBound(B) + 1
      Str = Str & " " & B(i-1)
      If i Mod 42 = 0 Then
         FSO.OpenTextFile(fDir&"\"&Name&"_"&n&".txt",8,True).WriteLine ar(0)&Str
         Str = "" : n = n + 1
      End If
   Next
End Sub

Function RegEx(Text)
   Set Re = New RegExp
   Re.Pattern = "\s+"
   Re.Global = True
   RegEx = Trim(Re.Replace(Text," "))
End Function
复制代码