формулы исправил, добавил динамические ссылки, но у вас по-моему есть ошибки в исходных данных (выделил красным), в одном месте (в 7 строке) неправильный день недели и нечетный номер недели (если вы платите со второй недели через две, то должна быть четная) из-за этого формула Александра (_Boroda_) некорректно считает значение из этой строки, причем в два месяца. В другом месте тоже неправильный день недели и нечетный номер недели, в обоих местах стоит пометка ps
формулы исправил, добавил динамические ссылки, но у вас по-моему есть ошибки в исходных данных (выделил красным), в одном месте (в 7 строке) неправильный день недели и нечетный номер недели (если вы платите со второй недели через две, то должна быть четная) из-за этого формула Александра (_Boroda_) некорректно считает значение из этой строки, причем в два месяца. В другом месте тоже неправильный день недели и нечетный номер недели, в обоих местах стоит пометка ps
массивная, для корректного расчета должна вводиться комбинацией Ctrl+Shift+Enter (выделил ее оранжевым), в файле я расписал на примере декабря как эта формула считается без столбца C
массивная, для корректного расчета должна вводиться комбинацией Ctrl+Shift+Enter (выделил ее оранжевым), в файле я расписал на примере декабря как эта формула считается без столбца Ckrosav4ig
Private Sub Worksheet_Calculate() Dim rrow As Range With Application: .ScreenUpdating = 0: .EnableEvents = 0:: .Calculation = xlCalculationManual For Each rrow In Intersect(ActiveSheet.UsedRange, [C:E]).Rows rrow.Offset(, 3).Resize(, 1).Formula = "=MAX(" & rrow.Address & ")" Next .Calculation = xlCalculationAutomatic: .ScreenUpdating = 1: .EnableEvents = 1: End With End Sub
[/vba]
можно в модуль листа такой код написать [vba]
Код
Private Sub Worksheet_Calculate() Dim rrow As Range With Application: .ScreenUpdating = 0: .EnableEvents = 0:: .Calculation = xlCalculationManual For Each rrow In Intersect(ActiveSheet.UsedRange, [C:E]).Rows rrow.Offset(, 3).Resize(, 1).Formula = "=MAX(" & rrow.Address & ")" Next .Calculation = xlCalculationAutomatic: .ScreenUpdating = 1: .EnableEvents = 1: End With End Sub
видимо сильно китайский, у мну тоже китайский, поставил ограничение 2 знака результат - 641.15. Вы своему помощнику судьи покажите такой фокус: на компе скопируйте в буфер обмена строку ((36076,59-20000)*0,03+800)/2 , запустите калькулятор и нажмите Ctrl+V>Enter
видимо сильно китайский, у мну тоже китайский, поставил ограничение 2 знака результат - 641.15. Вы своему помощнику судьи покажите такой фокус: на компе скопируйте в буфер обмена строку ((36076,59-20000)*0,03+800)/2 , запустите калькулятор и нажмите Ctrl+V>Enter
[/vba] (в конце кода. кстати, почему False? вы уже отключили обновление экрана в начале кода, тут нужно его включить (True). Вас спасает только то, что при завершении работы макроса обновление экрана автоматически включается)
[/vba] (в конце кода. кстати, почему False? вы уже отключили обновление экрана в начале кода, тут нужно его включить (True). Вас спасает только то, что при завершении работы макроса обновление экрана автоматически включается)
With tmpRange.Offset(, -6).FormatConditions 'дополнительно подсвечиваем даты из 1-ого Столбца .Delete With .Add(2, , "=ЕОШИБКА(ВПР(RC;Диапазон_3;2;))") .Interior.Color = RGB(204, 204, 153) End With End With
[/vba]
[vba]
Код
With tmpRange.Offset(, -6).FormatConditions 'дополнительно подсвечиваем даты из 1-ого Столбца .Delete With .Add(2, , "=ЕОШИБКА(ВПР(RC;Диапазон_3;2;))") .Interior.Color = RGB(204, 204, 153) End With End With
может я чего-то не так понял, но вот что у мну получилось [vba]
Код
Option Explicit Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _ Optional ByVal SearchDeep As Long = 999) As Collection Dim FSO As Object Set FilenamesCollection = New Collection Set FSO = CreateObject("Scripting.FileSystemObject") GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep Set FSO = Nothing End Function Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _ ByRef FileNamesColl As Collection, ByVal SearchDeep As Long) Dim curfold As Object, fil As Object, sfol As Object On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath) If Not curfold Is Nothing Then For Each fil In curfold.Files If fil.Name Like "*" & Mask Then FileNamesColl.Add fil Next SearchDeep = SearchDeep - 1 If SearchDeep Then For Each sfol In curfold.SubFolders GetAllFileNamesUsingFSO sfol.path, Mask, FSO, FileNamesColl, SearchDeep Next End If Set fil = Nothing: Set curfold = Nothing End If End Function
Sub sdf() Dim con As New ADODB.Connection Dim RS As New ADODB.Recordset Dim coll As Collection Dim ObjFile As Object Dim FilePath$, path$, ConnectionString$ ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.path & ";Extended Properties=dBASE IV" 'ConnectionString = "Driver={Microsoft dBASE Driver (*.dbf)};DriverID=277;Dbq=" & ThisWorkbook.path con.Open ConnectionString$ con.Execute "create table atable (name Text(50), cnt long)" For Each ObjFile In FilenamesCollection(ThisWorkbook.path, ".dbf", 2) FilePath = ObjFile.path: path$ = Replace(FilePath, ObjFile.Name, "") con.Execute "INSERT INTO atable SELECT Field1 as name, sum(Field2) as cnt From " & ObjFile.Name & " IN '" & path & "' [Dbase IV;DATABASE=" & FilePath & "] group by Field1" Next RS.Open "select name, sum(cnt) as sumcnt from atable group by name", con, 3, 3 [A1].CopyFromRecordset RS RS.Close con.Execute "drop table atable" con.Close Set con = Nothing: Set RS = Nothing End Sub
[/vba]
может я чего-то не так понял, но вот что у мну получилось [vba]
Код
Option Explicit Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _ Optional ByVal SearchDeep As Long = 999) As Collection Dim FSO As Object Set FilenamesCollection = New Collection Set FSO = CreateObject("Scripting.FileSystemObject") GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep Set FSO = Nothing End Function Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _ ByRef FileNamesColl As Collection, ByVal SearchDeep As Long) Dim curfold As Object, fil As Object, sfol As Object On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath) If Not curfold Is Nothing Then For Each fil In curfold.Files If fil.Name Like "*" & Mask Then FileNamesColl.Add fil Next SearchDeep = SearchDeep - 1 If SearchDeep Then For Each sfol In curfold.SubFolders GetAllFileNamesUsingFSO sfol.path, Mask, FSO, FileNamesColl, SearchDeep Next End If Set fil = Nothing: Set curfold = Nothing End If End Function
Sub sdf() Dim con As New ADODB.Connection Dim RS As New ADODB.Recordset Dim coll As Collection Dim ObjFile As Object Dim FilePath$, path$, ConnectionString$ ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.path & ";Extended Properties=dBASE IV" 'ConnectionString = "Driver={Microsoft dBASE Driver (*.dbf)};DriverID=277;Dbq=" & ThisWorkbook.path con.Open ConnectionString$ con.Execute "create table atable (name Text(50), cnt long)" For Each ObjFile In FilenamesCollection(ThisWorkbook.path, ".dbf", 2) FilePath = ObjFile.path: path$ = Replace(FilePath, ObjFile.Name, "") con.Execute "INSERT INTO atable SELECT Field1 as name, sum(Field2) as cnt From " & ObjFile.Name & " IN '" & path & "' [Dbase IV;DATABASE=" & FilePath & "] group by Field1" Next RS.Open "select name, sum(cnt) as sumcnt from atable group by name", con, 3, 3 [A1].CopyFromRecordset RS RS.Close con.Execute "drop table atable" con.Close Set con = Nothing: Set RS = Nothing End Sub
Тут же черным по белому написано, что CSV это xlCSV или 6, а вы сохраняете книгу excel 97-2003 с расширением csv. При правильном указании формата расширение указывать не обязательно, т.е. [vba]
Код
ActiveWorkbook.SaveAs Filename:= "C:\Users\Desktop\list" & i \ 10, FileFormat:=6
[/vba]
смотрите мой пост, там документы именуются правильно или у себя замените [vba]
Тут же черным по белому написано, что CSV это xlCSV или 6, а вы сохраняете книгу excel 97-2003 с расширением csv. При правильном указании формата расширение указывать не обязательно, т.е. [vba]
Код
ActiveWorkbook.SaveAs Filename:= "C:\Users\Desktop\list" & i \ 10, FileFormat:=6
Private Sub AlphaBET() ArrA = Evaluate("transpose(mid(""tб<UЁJnx#я.Уd9екwТл{'+2g:ч%M6Y?ЗzКLжi!ющZ§~Qk`" & _ "ЖoЦРNдЪВ^7OpRXS ШрDДаCСГHu@ПгjФь>м14G0Нцr;Хэп$|eqBcф,lМтхБm&ш€" & _ "ОFо]ИЯ\ЮA[vйс8/3Щ_иЭъVPыз5h=нbTё(-""""y)ув}*ЕЙЫЛЧI№ЬfWАKasE""," & _ "row(1:164),1))") End Sub
Private Sub AlphaBET() ArrA = Evaluate("transpose(mid(""tб<UЁJnx#я.Уd9екwТл{'+2g:ч%M6Y?ЗzКLжi!ющZ§~Qk`" & _ "ЖoЦРNдЪВ^7OpRXS ШрDДаCСГHu@ПгjФь>м14G0Нцr;Хэп$|eqBcф,lМтхБm&ш€" & _ "ОFо]ИЯ\ЮA[vйс8/3Щ_иЭъVPыз5h=нbTё(-""""y)ув}*ЕЙЫЛЧI№ЬfWАKasE""," & _ "row(1:164),1))") End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
[/offtop]
