Set FSO = CreateObject("Scripting.FileSystemObject")
ReDim arr(1 To .SelectedItems.Count, 1 To 3) For Each AFile In .SelectedItems 'ïåðåáîð ôàéëîâ â ïàïêå i = i + 1 arr(i, 3) = FSO.GetBaseName(AFile) arr(i, 1) = Format(todate(CStr(arr(i, 3))), "yyyymmdd") arr(i, 2) = AFile Next uSort arr, 1
For i = 1 To UBound(arr) Application.StatusBar = "Open file " & arr(i, 2) DoEvents: DoEvents: DoEvents: DoEvents: DoEvents Set wb = Workbooks.Open(Filename:=arr(i, 2), ReadOnly:=True, UpdateLinks:=False, CorruptLoad:=xlRepairFile) Call analiz(r, rr, CStr(arr(i, 3)), wb, outwb, dt) wb.Close 0 Next
End With
Dim sh As Worksheet For Each sh In outwb.Worksheets sh.Activate sh.Range("D2").Select ActiveWindow.FreezePanes = True Next outwb.Sheets(1).Activate
With Application: .StatusBar = False: .CutCopyMode = False: .ScreenUpdating = True: End With
End Sub
[/vba]
потом всякие странички добавляются, сортировка и прочая фигня
И проблемный кусок dt = todate(fff), fff - имеет значение 270719 А уже следующая строчка wd = Choose(Weekday(dt), тут dt выглядит как 27.07.719 Откуда тут эта семерка появилась перед 19, как ее убрать?
[vba]
Код
Private Sub analiz(r, rr, fff$, wb As Object, outwb As Object, dt As Date) Dim wd As String Dim i1&, i2&, i3&, i4&, i5&, i6&, i7&, i8&, i9&, i10&, t$ Dim a(), i&, ii&, iL&, flag As Boolean, ub& Dim sc As Range, acol&
If IsDate(todate(fff)) Then dt = todate(fff) wd = Choose(Weekday(dt), "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") End If
[/vba]
макрос слишком длинный, весь его приложить я не могу. Основные куски где встречается date скопировал в порядке как они в макросе встречаются. Так-то я обычным batником переименовываю файлы в папке, как мне нужно : ), но хочется понять где ошибка.
После изменения формата входящего файла с 27.07.2019.xlsx на 27.07.19.xlsx, у меня перестал работать макрос, неправильный говорит у тебя dt
это в самом начале макроса [vba]
Код
With Application.FileDialog(msoFileDialogFilePicker) .Title = "select files" .InitialFileName = stt.[inpath] & "*.xls*" .AllowMultiSelect = True If .Show = False Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
ReDim arr(1 To .SelectedItems.Count, 1 To 3) For Each AFile In .SelectedItems 'ïåðåáîð ôàéëîâ â ïàïêå i = i + 1 arr(i, 3) = FSO.GetBaseName(AFile) arr(i, 1) = Format(todate(CStr(arr(i, 3))), "yyyymmdd") arr(i, 2) = AFile Next uSort arr, 1
For i = 1 To UBound(arr) Application.StatusBar = "Open file " & arr(i, 2) DoEvents: DoEvents: DoEvents: DoEvents: DoEvents Set wb = Workbooks.Open(Filename:=arr(i, 2), ReadOnly:=True, UpdateLinks:=False, CorruptLoad:=xlRepairFile) Call analiz(r, rr, CStr(arr(i, 3)), wb, outwb, dt) wb.Close 0 Next
End With
Dim sh As Worksheet For Each sh In outwb.Worksheets sh.Activate sh.Range("D2").Select ActiveWindow.FreezePanes = True Next outwb.Sheets(1).Activate
With Application: .StatusBar = False: .CutCopyMode = False: .ScreenUpdating = True: End With
End Sub
[/vba]
потом всякие странички добавляются, сортировка и прочая фигня
И проблемный кусок dt = todate(fff), fff - имеет значение 270719 А уже следующая строчка wd = Choose(Weekday(dt), тут dt выглядит как 27.07.719 Откуда тут эта семерка появилась перед 19, как ее убрать?
[vba]
Код
Private Sub analiz(r, rr, fff$, wb As Object, outwb As Object, dt As Date) Dim wd As String Dim i1&, i2&, i3&, i4&, i5&, i6&, i7&, i8&, i9&, i10&, t$ Dim a(), i&, ii&, iL&, flag As Boolean, ub& Dim sc As Range, acol&
If IsDate(todate(fff)) Then dt = todate(fff) wd = Choose(Weekday(dt), "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") End If
[/vba]
макрос слишком длинный, весь его приложить я не могу. Основные куски где встречается date скопировал в порядке как они в макросе встречаются. Так-то я обычным batником переименовываю файлы в папке, как мне нужно : ), но хочется понять где ошибка.mjasert
Сообщение отредактировал mjasert - Среда, 04.09.2019, 14:08
mjasert, - Прочитайте Правила форума - Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)
mjasert, - Прочитайте Правила форума - Приложите файл с исходными данными и желаемым результатом (можно вручную) в формате Excel размером до 100кб согласно п.3 Правил форума - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
Private Function todate(s$) On Error Resume Next todate = False s = ExtrNum(s) todate = DateValue(Left(s, 2) & "/" & Mid(s, 3, 2) & "/" & Right(s, 4)) On Error GoTo 0 End Function
[/vba]
[vba]
Код
Private Function todate(s$) On Error Resume Next todate = False s = ExtrNum(s) todate = DateValue(Left(s, 2) & "/" & Mid(s, 3, 2) & "/" & Right(s, 4)) On Error GoTo 0 End Function