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
[/vba]
все-таки не удержался [vba]
Код
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
еще вариант, для конкретно для этого сайта, на других работать не будет [vba]
Код
Function GetImageLink$(url$) Application.Volatile False Dim oHTML: Set oHTML = CreateObject("MSXML2.XMLHTTP") oHTML.Open "GET", url, False: oHTML.send If oHTML.Status <> 200 Then Set oHTML = Nothing: Exit Function Else Dim oDoc: Set oDoc = CreateObject("htmlfile") oDoc.body.innerHTML = Split(oHTML.responseText, "item-image")(1) On Error Resume Next GetImageLink = oDoc.getElementsByTagName("img")(0).href Set oDoc = Nothing: Set oHTML = Nothing End Function
[/vba]
еще вариант, для конкретно для этого сайта, на других работать не будет [vba]
Код
Function GetImageLink$(url$) Application.Volatile False Dim oHTML: Set oHTML = CreateObject("MSXML2.XMLHTTP") oHTML.Open "GET", url, False: oHTML.send If oHTML.Status <> 200 Then Set oHTML = Nothing: Exit Function Else Dim oDoc: Set oDoc = CreateObject("htmlfile") oDoc.body.innerHTML = Split(oHTML.responseText, "item-image")(1) On Error Resume Next GetImageLink = oDoc.getElementsByTagName("img")(0).href Set oDoc = Nothing: Set oHTML = Nothing End Function
Sub beereator() Dim i&, n&, WBtemp As Workbook, WSH As Worksheet Set WSH = ActiveSheet: n = 10 With Application: .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0 For i = WSH.Cells.SpecialCells(xlCellTypeLastCell).Row \ n To 0 Step -1 Set WBtemp = Workbooks.Add WSH.Rows(i * n + 1).Resize(10).Cut WBtemp.Sheets(1).[A1] WBtemp.SaveAs Filename:="C:\Users\Yura\Desktop\b" & i + 1, FileFormat:=6 WBtemp.Close Next .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1: End With Set WBtemp = Nothing: Set WSH = Nothing End Sub
[/vba]
[vba]
Код
Sub beereator() Dim i&, n&, WBtemp As Workbook, WSH As Worksheet Set WSH = ActiveSheet: n = 10 With Application: .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0 For i = WSH.Cells.SpecialCells(xlCellTypeLastCell).Row \ n To 0 Step -1 Set WBtemp = Workbooks.Add WSH.Rows(i * n + 1).Resize(10).Cut WBtemp.Sheets(1).[A1] WBtemp.SaveAs Filename:="C:\Users\Yura\Desktop\b" & i + 1, FileFormat:=6 WBtemp.Close Next .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1: End With Set WBtemp = Nothing: Set WSH = Nothing 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
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
Тут же черным по белому написано, что 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
может я чего-то не так понял, но вот что у мну получилось [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
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] (в конце кода. кстати, почему False? вы уже отключили обновление экрана в начале кода, тут нужно его включить (True). Вас спасает только то, что при завершении работы макроса обновление экрана автоматически включается)
[/vba] (в конце кода. кстати, почему False? вы уже отключили обновление экрана в начале кода, тут нужно его включить (True). Вас спасает только то, что при завершении работы макроса обновление экрана автоматически включается)
видимо сильно китайский, у мну тоже китайский, поставил ограничение 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
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
массивная, для корректного расчета должна вводиться комбинацией Ctrl+Shift+Enter (выделил ее оранжевым), в файле я расписал на примере декабря как эта формула считается без столбца C
массивная, для корректного расчета должна вводиться комбинацией Ctrl+Shift+Enter (выделил ее оранжевым), в файле я расписал на примере декабря как эта формула считается без столбца Ckrosav4ig
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
[/offtop]
