Я использую VBA для поиска в сетевой папке, в которой обычно содержится около 4000 .txt файлов, и перемещения плохих файлов, содержащих строки, перечисленные в диапазоне Excel, в другую папку. Оставшиеся хорошие файлы архивируются и перемещаются / разбрасываются, а файлы .txt перемещаются в одну папку.
Вот мой код, выполнение которого занимает много часов, вероятно, из-за двойной петли. Пожалуйста, помогите мне изменить это, чтобы работать быстрее / эффективнее.
Option Compare Text
Sub SDRFiles()
Dim lastRow As Integer
Dim Fldr As Object
Dim BaseFldr As String
Dim sdrDNU As String
Dim sdrDateFldr As String
Dim fDate
Dim FSO As Object
Dim FirstTwo As String
Dim NineTen As String
Dim Lead As String
Dim BadFile As Integer
Dim sdrFile As String
Dim fldExists As String
'Process SDR files. Move files off landing zone to working folder, pull out and store bad files,
'zip good files and move to each owner's folder, save good txt in Data Czar's folder.
'Landing zone
BaseFldr = "\\nasgw013pn\hedis_prod\SDR FILES"
'new SDR folder for files
fDate = Format(Date, "mmddyyyy")
'Processing fldr
sdrDateFldr = BaseFldr & "\" & fDate & "_" & shControl.cboMonth.Value & theCycle
fldExists = Dir(sdrDateFldr)
If fldExists = "" Then
MkDir sdrDateFldr
End If
'Move all files from landing zone to processing folder
Set FSO = CreateObject("scripting.filesystemobject")
extn = "\*.txt"
FSO.MoveFile Source:=BaseFldr & extn, Destination:=sdrDateFldr & "\"
'Do Not Use sub folder for bad files
sdrDNU = sdrDateFldr & "\DNU"
fldExists = Dir(sdrDNU)
If fldExists = "" Then
MkDir sdrDNU
End If
'Good Text File destination
TextFileFldr = fDate & "_" & shControl.cboMonth.Value & theCycle & "_txt"
TextFileDest = sdrDateFldr & "\" & TextFileFldr
fldExists = Dir(TextFileDest)
If fldExists = "" Then
MkDir TextFileDest
End If
'Bottom of bad file strings
lastRow = shSDR.Range("A" & Rows.Count).End(xlUp).Row
Set xFolder = FSO.GetFolder(sdrDateFldr)
'loop thru folder
For Each xFile In xFolder.Files 'About 4000 files. can vary
Fname = xFile.Name
FirstTwo = Left(Fname, 2)
NineTen = Mid(Fname, 9, 2)
Lead = Mid(Fname, 16, 2)
'range with list of bad strings
For Each Item In shSDR.Range("A2:A" & lastRow) 'about 10 strings. can vary
'Hold file from 1st loop and test. If bad file, move to Do Not Use (DNU) folder
If InStr(Fname, Item) > 0 Or _
(InStr(Fname, "PWOEY") > 0 And FirstTwo <> "OH") Or _
(InStr(Fname, "HNARST") > 0 And FirstTwo <> NineTen) Or _
(InStr(Fname, "FTANDHEIPANE") > 0 And FirstTwo <> Lead) Then
'bad file - move to DNU Folder
Name sdrDateFldr & "\" & Fname As sdrDNU & "\" & Fname
'Bad file indentified
BadFile = 1
'exit this loop if matched and get next file
Exit For
End If
Next Item
If BadFile = 0 Then
'Good file - zip it and move each txt file to same folder
Call Zipp(sdrDateFldr & "\" & Replace(Fname, "txt", "zip"), sdrDateFldr & "\" & Fname)
‘move good zipped file to its own specific folder – NY folder, FL folder TX folder etc.
Call MoveIt(sdrDateFldr & "\" & Replace(Fname, "txt", "zip"), Replace(Fname, "txt", "zip"))
End If
BadFile = 0
Next xFile
End Sub
'says function but it really a sub
Public Function Zipp(ZipName, FileToZip)
'Called by all modules to create a Zip File
‘Dim FSO As Object
Dim oApp As Object
If Len(Dir(ZipName)) > 0 Then Kill (ZipName)
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
dFile = Dir(FileToZip)
On Error Resume Next
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(CVar(ZipName)).CopyHere CVar(FileToZip)
DoEvents
'====HELP!!! ================Please help me with the following. It hangs sporadically, sometimes at
'============================file 200 or may the 1500th file. I have to esc esc and continue.
'============================For 10 to 20 files it seems to run fine
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(CVar(ZipName)).Items.Count = 1
Application.Wait (Now + TimeValue("0:00:06"))
DoEvents
Loop
'=============================================================================
'=============================================================================
'USED ONLY BY Sub SDRFiles()
'THIS PART OF ZIPP SAVES THE .TXT FILE TO DATA CZAR'S FOLDER
'SDR Processing - Move text file
If SDR = "Y" And Len(Dir(FileToZip)) > 0 Then
SetAttr FileToZip, vbNormal
Name FileToZip As TextFileDest & "\" & dFile
End If
Set oApp = Nothing
‘Set FSO = Nothing
End Function
Sub MoveIt(PathZip, ZipFileName)
Dim rootPlusSubFolder As String
Dim NasState As Range
Dim NasLocation As String
Dim FSO As Object
'MOVE ZIPP FILES TO FOLDERS
'MOVE FILES TO IMP FOLDER - find state in extract name and MOVE file to that folder
'Bottom of state list
botRow = shNasMoves.Cells(shNasMoves.Rows.Count, 7).End(xlUp).Row
'Bottom of list of import folder names
NasBot = Sheets("NASMoves").Cells(Rows.Count, "A").End(xlUp).Address
'Look up state to get import folder path
Application.FindFormat.Clear
Set NasState = shNasMoves.Range("A1:" & NasBot).Find(What:=Left(ZipFileName, 2))
'if state found, get folder location URL
If Not NasState Is Nothing Then
NasLocation = NasState.Offset(0, 1).Value
'current month for sub folder file name
CurMonthFolder = "CS_" & theMo & "_" & theCycle & "\"
'Combined destination folder and sub folder name
rootPlusSubFolder = NasLocation & CurMonthFolder
Set FSO = CreateObject("scripting.filesystemobject")
'if CS Import SUB folder doesn't exist, create it - sometimes DIR sometimes FSO
If Not FSO.FolderExists(rootPlusSubFolder) Then
FSO.CreateFolder (rootPlusSubFolder)
End If
'Final dest Fldr
If Not FSO.FolderExists(rootPlusSubFolder & "\" & "SDR") Then
FSO.CreateFolder (rootPlusSubFolder & "\" & "SDR")
End If
'try to stop pop up
With Application
.EnableEvents = False
.DisplayAlerts = False
End With
'Debug.Print rootPlusSubFolder & "SDR"
On Error Resume Next
'move file from Root to destination folder/sub folder
FSO.MoveFile PathZip, rootPlusSubFolder & "SDR\" & ZipFileName
With Application
.EnableEvents = True
.DisplayAlerts = True
End With
End If
End Sub