У меня проблемы с таргетингом на конкретное имя файла.В качестве примера: «FE2620F_18220_D02_102_AA03.csv» Макрос просит пользователя выбрать каталог, содержащий файлы .csv.
Файлы обрабатываются по порядку (по крайней мере, это цель).Когда я запускаю макрос с помощью кнопки формы или из панели макросов или из редактора с помощью кнопки воспроизведения, этот конкретный файл пропускается.
Файлы с такими именами, как "FE2620F_18220_D02_102_E03.csv" или "REF_STD_092618_6.csv", работают нормально.Во время отладки с помощью команды Step Into все файлы работают нормально.
На самом деле, если я просто перешагну точку, в которой файл обычно будет удален, то нажму кнопку «Продолжить», все работает нормально.
Sub reflectivity()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'This code prompts a user for a directory that contains files of type extType,
'then extracts average values that are defined by r1,r2,r3 and writes them,
'along with the file name to the next open cell in the workbook aBook including
'a blank line after each directory worth of files
'then it closes the books and saves the changes
Dim r1 As Range, r2 As Range, r3 As Range
Dim Tr1 As Range, Tr2 As Range, Tr3 As Range, Tr4 As Range
Dim strTr1 As String, strTr2 As String, strTr3 As String, strTitle As String
Dim meas1 As Double, meas2 As Double, meas3 As Double
Dim fDialog As FileDialog
Dim pathName As String, extType As String, operFile As String, targetPath As String, targetpath2 As String, fileType As String
Dim prefix As String, file As String
Dim count As Integer, nextEntry As Integer
Dim aBook As Workbook, bBook As Workbook
Dim aSheet As Worksheet, bSheet As Worksheet, wsTest As Worksheet
Set aBook = ThisWorkbook
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets("Calc")
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.NAME = "Calc"
End If
Set aSheet = Worksheets("Calc")
'set bSheet to the workbook where you want to add the summarized data
Set bBook = ThisWorkbook
Set bSheet = bBook.Worksheets("Sheet1")
'choose which type of file has your data to extract
fileType = "*.csv"
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select Directory"
.ButtonName = "Select"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pathName = .SelectedItems(1) & "\"
End With
extType = fileType
operFile = Dir(pathName & extType)
prefix = "TEXT;"
'open csv into sheet(1) and csv_get it
Set r1 = Worksheets("Calc").Range("$B$43:$B$89")
Set r2 = Worksheets("Calc").Range("$B$152:$B$199")
Set r3 = Worksheets("Calc").Range("$B$311:$B$352")
Do While operFile <> ""
file = prefix & pathName & operFile
With aSheet.QueryTables.Add(Connection:=file, Destination:=aSheet.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
Set r1 = Worksheets("Calc").Range("$B$43:$B$89")
Set r2 = Worksheets("Calc").Range("$B$152:$B$199")
Set r3 = Worksheets("Calc").Range("$B$311:$B$352")
'first cell gets written
meas1 = csv_get(r1, aSheet)
'second cell gets written
meas2 = csv_get(r2, aSheet)
'third cell gets written
meas3 = csv_get(r3, aSheet)
'this part finds the next line in the bSheet and writes the measurements to the new line
nextEntry = nextLine(bBook, bSheet)
strTr1 = "B" & nextEntry
strTr2 = "C" & nextEntry
strTr3 = "D" & nextEntry
strTitle = "A" & nextEntry
Set Tr1 = Range(strTr1)
Set Tr2 = Range(strTr2)
Set Tr3 = Range(strTr3)
Set Tr4 = Range(strTitle)
bSheet.Activate
With bSheet
Tr1.Value = Round(meas1, 4)
Tr1.NumberFormat = "0.00%"
Tr2.Value = Round(meas2, 4)
Tr2.NumberFormat = "0.00%"
Tr3.Value = Round(meas3, 4)
Tr3.NumberFormat = "0.00%"
Tr4.Value = Replace(operFile, ".csv", "", 1, 1)
End With
operFile = Dir()
Loop
NextCode:
'in case of cancel
pathName = pathName
If pathName = "" Then GoTo ResetSettings
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo nothingtodelete
aSheet.QueryTables(1).SaveData = False
aSheet.QueryTables.item(1).Delete
nothingtodelete:
Application.DisplayAlerts = False
Sheets("Calc").Delete
Application.DisplayAlerts = True
End Sub
Public Function csv_get(locString As Range, wSheet As Worksheet) As Double
wSheet.Parent.Activate
Debug.Print locString.Address
csv_get = Application.WorksheetFunction.Average(locString)
End Function
Public Function nextLine(wBook As Workbook, wSheet As Worksheet) As Integer
Dim lastrow As Integer
wBook.Activate
With wSheet
If Application.WorksheetFunction.CountA(wSheet.Cells) <> 0 Then
nextLine = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
Else
nextLine = 1
End If
End With
End Function