Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 След.
Проблема с запросом XMLHTTPRequest, не возвращает корректные данные с сайта
 
Спасибо doober, я знал, что на форуме есть добрые люди.
Я так понял, что мне нужно изменить строку запроса
с https://auction.openprocurement.org/tenders/2889f213faf9415ba9d27e97fd675cd9
на https://auction.openprocurement.org/database/2889f213faf9415ba9d27e97fd675cd9
что не является проблемой.
Также изучить как обработать ответ JSON

Я так понял, что эта запись на странице
<script type=text/javascript>
var db_url = location.protocol + '//' + location.host + '/database';
var auction_doc_id = '';
говорит о том что перенаправляется запрос к базе данных.
Изменено: TSN - 22 окт 2020 10:04:32
Проблема с запросом XMLHTTPRequest, не возвращает корректные данные с сайта
 
Добрый день уважаемые форумчане, помогите решить задачу.
Есть программа которая занимается парсингом нескольких сайтов, в целом выполняется 15 различных процедур. Парсинг построен на объекте InternetExplorer.Application На протяжении нескольких лет все работает, но есть некоторые проблемы с IE (в отделе несколько компов с разными версиями Windows и Ексель приходится лепить различные костыли для нормальной работы с IE, также не устраивает скорость выполнения парсинга некоторых сайтов).
Решил перейти на объект MSXML2.XMLHTTP, в целом все прошло успешно, 14 процедур работают отлично, скорость парсинга повысилась в разы.
Парсинг одной процедуры не возвращает корректные данные.
Вместо:
ТОВ "Наименование 1" 148 000,00 грн
ТОВ "Наименование 2" 163 440,00 грн
Выдает:
Initial bids Bidders
{{ bid_info.label[lang]||"-" }} You Normilized Price {{ bid_info['amount_features']|fraction }}

InternetExplorer до сегодняшнего дня возвращал корректные данные, сегодня тоже перестал.
Исследуя страницу в браузере обратил внимание, что появился новый тег <span, раньше его не было возможно в нем причина.
Перепробовал различные варианты запросов к странице, безрезультатно.
Помогите найти решение как получить нормальный ответ.

Пример кода
Код
Option Explicit
Option Compare Text

''' Для примера страница сайта с которой есть проблема XML
Private Const strURL As String = "https://auction.openprocurement.org/tenders/2889f213faf9415ba9d27e97fd675cd9"

Sub NotWorkingParser_XML()
Dim objHTMLDoc As HTMLDocument
''' объект objHTMLDoc As HTMLDocument, объявлен ранним связыванием
''' Tools -> References -> Microsoft HTML Object Library. > C:\Windows\SysWOW64\mshtml.tlb
Dim objXML As Object, Tag1, vl1
Dim strOtvetAukcion As String, strTrimer As String

Set objHTMLDoc = New HTMLDocument
Set objXML = CreateObject("MSXML2.XMLHTTP.6.0")
''' Формирование заголовка запроса
objXML.Open "GET", strURL, False
objXML.setRequestHeader "Accept", "*/*"
objXML.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:49.0) Gecko/20100101 Firefox/58.0.1"
objXML.setRequestHeader "Proxy-Connection", "Keep-Alive"
objXML.setRequestHeader "Cache-Control", "no-cache"
objXML.setRequestHeader "If-Modified-Since", "Thu, 1 Jan 1970 00:00:00 UTC"
objXML.setRequestHeader "Content-Type", "text/xml"
'''Чтобы браузер распарсил ответ сервера в свойство responseXML, _
   в ответе должен быть заголовок Content-Type: text/xml. Иначе свойство responseXML будет равно null.
'''objXML.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objXML.sEnd
''' Получить ответ
While objXML.readyState <> 4: DoEvents: Wend
objHTMLDoc.body.innerHTML = objXML.responseText

''' ===========================================
''' В процессе реализации получить ответ использовались различные методы
''' getElementById, getElementsByClassName, getElementsByTagName
''' setRequestHeader "Content-Type", "text/xml", "application/x-www-form-urlencoded", "text/html"
''' objHTMLDoc.body.innerHTML = ConvertBytesToString(objXML.responseBody)
''' ничего не помогло (:
''' ===========================================

''' статус аукциона
Set Tag1 = objHTMLDoc.getElementsByClassName("header-auction-item navbar-brand pull-left round-info timer-text")
Debug.Print Trim$(Tag1.Item(0).innerText) & vbNewLine
''' набор данных шаги аукциона
For Each Tag1 In objHTMLDoc.getElementsByClassName("auction-round")
  For Each vl1 In Tag1.Children
    strTrimer = Trim$(Application.WorksheetFunction.Clean(vl1.innerText))
    strOtvetAukcion = strOtvetAukcion & strTrimer & vbNewLine
  Next
  Debug.Print strOtvetAukcion & vbNewLine
  strOtvetAukcion = vbNullString
Next
Set objHTMLDoc = Nothing
Set objXML = Nothing
End Sub
      
Sub NotWorkingParser_IE()
''' Минусы работы с InternetExplorer
''' 1. Проблемы возникают при наличии в отделе нескольких компов с разными версиями Windows, IE
''' 2. Скорость выполнения парсинга сайтов. По сравнению с XML иногда достигает разницы в десятки раз.
Dim objIE As Object
Dim strOtvetAukcion As String, strTrimer As String
Dim Tag1, vl1
    Set objIE = CreateObject("InternetExplorer.Application"):
    objIE.navigate strURL
    DoEvents
    While objIE.busy Or (objIE.readyState <> 4): DoEvents: Wend
'    Do While objIE.busy Or (objIE.readyState <> 4)
'      DoEvents: Application.Wait (Now + TimeValue("0:00:02"))
'    Loop
    ''' статус аукциона
    Set Tag1 = objIE.document.getElementsByClassName("header-auction-item navbar-brand pull-left round-info timer-text")
    Debug.Print Trim$(Tag1.Item(0).innerText)
    ''' набор данных шаги аукциона
    For Each Tag1 In objIE.document.getElementsByClassName("auction-round")
      For Each vl1 In Tag1.Children
        strTrimer = Trim$(Application.WorksheetFunction.Clean(vl1.innerText))
        strOtvetAukcion = strOtvetAukcion & strTrimer & vbNewLine
      Next
      ''' ответ веб-страницы
      Debug.Print strOtvetAukcion
      strOtvetAukcion = vbNullString
    Next
objIE.Quit: Set objIE = Nothing
End Sub
        
Private Function ConvertBytesToString(ArrByte)
Dim ADOStream
Set ADOStream = CreateObject("ADODB.Stream")
  With ADOStream
    .Type = 1 'adTypeBinary
    .Open:  .Write ArrByte: .Position = 0
    .Type = 2 'adTypeText
    .Charset = "windows-1251"
     ConvertBytesToString = .ReadText
    .Close
  End With
Set ADOStream = Nothing
End Function

Автоматическое обновление ссылок Excel 2010 - не работает у части пользователей
 
Anastasia111, Посмотрите настройки Ексель на всех компьтерах.
Параметры > Центр управления безопасностью > Внешнее содержимое > Параметры безопасности для связей в книге и Пармаметры безопасности для подключения к данным.
Возможно это решит вашу проблему.
Зачитать и сохранить плейлисты
 
Цитата
Acid Burn написал:
1. Теперь всё непонятое макросом будет улавливаться в соответствующий столбец?Или, если структура будет совсем иная/кривая, что-то всё же может быть пропущено?
Да если структура будет совсем иная/кривая, что-то может быть пропущено. Я алгоритм анализа писал на основании данных  с файлов примеров. Структура файлов m3u похожа на структуру Xml, возможно применив XML DOM проще и без ошибок можно парсить m3u файлы. Мои познания в XML DOM слабоваты поэтому не применял его.
Цитата
Acid Burn написал:
- изменить имена листов (сейчас в обоих файлах листы названы ASX*)
Не заметил сорян, это просто изменить.

Цитата
Acid Burn написал:
перетащить инфо из столбца H в столбец C, если тот не заполнен
Изначально в третей версии так и сделал, потом убрал решив, что будет лишним :)
Цитата
Acid Burn написал:
сделать ссылки кликабельными или обернуть в функцию =ГИПЕРССЫЛКА("Ссылка";"Сервер")
а функцию ГИПЕРССЫЛКА и вовсе вряд ли можно применить из-за осложнения поиска дубликатов.
Гиперссылки сделать просто при условии формирования нового файла в момент удаления дубликатов.
Для процедур (кнопки) Update file, RemoveDuplicates нужно переписывать алгоритм поиска дубликатов с учетом наличия гиперссылок.

В целом все это мелочи, еще оскому не сбил в программировании на VBA, допилю и выложу обновленную версию.
Зачитать и сохранить плейлисты
 
Цитата
Acid Burn написал:
На счёт столбца "Не классифицировано":посмотрите в Mult.m3u8 ссылку  https://strm.yandex.ru/vh-ott-converted/ott-content/328514357 Parser потерял кусок ", но боялись спросить...".Вот такие куски я и хотел бы видеть в "Не классифицировано", чтобы вручную разобрать и перенести на место.
Когда писал первый вариант не заметил, что  строки файлов м3u различаются
Это основная структура записи
#EXTINF:-1 group-title="Герои Энвелла",Сезон 1 - Серия 10 - Неизвестная локация
https: //strm.yandex.ru/vh-ott-converted/ott-content/493306269-41178fc958d098058dda2b906148c594/master_quality.m3u8
В приведенном примере Вами другая
Алгоритм анализа фалов m3u переписал, работает корректно.
Цитата
Acid Burn написал:
Вместо выбора папки лучше вернуть выбор файлов с strMyDocuments = Application.ActiveWorkbook.Path & "\".
Добавил две константы и реализацию диалогов. Это пример того как можно собрать с двух вариантов один.
'константа для выбора управления диалоговыми окнами выбора файла или папки
'0 - используется диалог выбора файлов, 1 - используется диалог выбора папки
Private Const SHOWUSERDIALOG As Byte = 0
'константа для выбора папки сохранения
'0 - сохраняет результатирующий файл по умолчанию в папку с Parserом, 1 - используется диалог выбора папки
Private Const SAVEDUSERPATH As Byte = 0
Меняйте значения этих констант и получите разную реализацию работы пользователя с диалоговыми окнами и путями сохранения файлов ответов.
По умолчанию работает с папкой в которой лежит программа.
Цитата
Acid Burn написал:
Все m3u и asx нужно собрать в одну таблицу в одном файле
m3u файлы собираются в одну таблицу  с удалением дубликатов (с тех файлов которые выбрал пользователь или тех которые лежат в одной папке), сохраняются в один файл ResultatM3U_дата_время. Asx файлы оставил в тойже реализации, собираются данные в отдельный файл ResultatASX_дата_время.  Asx файлов много, данных на выходе мало, и данные таких файлов отличаются от таблиц m3u файлов.
Цитата
Acid Burn написал:
на том листе, с которого запущен макрос.
Программа работает с внешними файлами, в себя ничего не загружает, реализованы диалоги обращения к внешним файлам.  Мое мнение вы знаете мухи отдельно, котлеты отдельно.
Цитата
Acid Burn написал:
- При повторном запуске макроса новые данные должны добавляться в ту же таблицу (если реально, то без дублей).- То, что "источник разный" не важно, пусть остаётся первый попавшийся - на выходе всё равно будет новый файл.
Написал процедуру парсинга файлов с возможностью дописать данные в существующий файл выбранный пользователем. Данные добавляются в имеющуюся таблицу в файле с удалением дубликатов.
Дополнительно написал процедуру удаления дубликатов данных в существующем файле ответе (ResultatM3U_дата_время. ) выбранном пользователем (вспомогательная процедура). Основное назначение при условии, что пользователь самостоятельно собрал с нескольких файлов ответов одну таблицу.

Пользуйтесь.
Изменено: TSN - 29 сен 2020 10:02:06
Зачитать и сохранить плейлисты
 
vikttur, Извините, я давно не был на этом форуме, правила забыл, повторно не читал.
БМВ мне на счётчик наплевать, я благодарен этому форуму за знания в программировании в Vba, с этих страниц много лет назад началось моё обучение. Хотел бы накрутить счётчик, писал бы короткие фразы во всех постах не вникая в суть вопроса :).
Acid Burn, Ваш последний пост уже немного похож на тех задание, это как раз, то о чем писали учасники форума в постах выше, например пост 22. Я сделал ровно так как понял из текста в первом посте. В целом у вас есть два варианта программы выполняющей одну и ту же задачу, перепишите код на свое усмотрение, соберите с двух одно, добавте дополнительный анализ строк файлов. Я вам дал фундамент для решения задачи, дальше наращивайте по своему усмотрению. Я в свою очередь ушёл в сон, а завтра на море до понедельника. Если на следующей неделе будет время на работе тогда смогу доработать.
Цитата
- Все m3u и asx нужно собрать в одну таблицу в одном файле, на том листе, с которого запущен макрос.
Я не рекомендую в файл с програмным кодом загружать данные в таком большем объеме, в один прекрасный день произойдёт сбой и можно потерять программу и данные. Мухи отдельно, котлеты отдельно, это моё мнение.  
Изменено: TSN - 24 сен 2020 21:52:17
Зачитать и сохранить плейлисты
 
Цитата
Acid Burn написал:
Закономерность - одинаковая ссылка на ресурс (названия и т.п. могут отличаться, но, если ссылка та же, то это точно дубль).
Закономерность не полноценная вот пример
ИсточникКатегорияНазваниеСсылка
Films.m3u8Не попали в категории   по годамentermusictvhttp ://v2.catcast.me/content/36007/index.m3u8
TV.m3u8Фильмовыеentermusictvhttp ://v2.catcast.me/content/36007/index.m3u8
Как видно из таблицы ссылка на ресурс одна, но источник разный. Какой источник должен остаться ?
А в целом да, дубликатов много, из данных файлов примеров 79952 ссылки из них уникальных 74360 шт.
Изменено: TSN - 24 сен 2020 12:16:53
Зачитать и сохранить плейлисты
 
Цитата
Acid Burn написал:
Я имел ввиду заменить SpecialFolders("MyDocuments") на Application.ActiveWorkbook.Path.
У большенства пользователей папка мои документы является основной для использования, поэтому было принято решение использовать именно ее как папку по умолчанию, в коде последеней программы это всего одна строка, которую можно изменить под себя
Код
strMyDocuments = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\"
Изменив значение переменной strMyDocuments можно получить желаемое. Например так
Код
strMyDocuments = Application.ActiveWorkbook.Path & "\"
Изменено: TSN - 24 сен 2020 11:56:50
Зачитать и сохранить плейлисты
 
Переписал часть кода, получился альтернативный вариант
Изменено:
1.  При запуске выбирается папка с файлами, вместо файлов.
2.  Все данные с файлов m3u собираются в одну таблицу в одном файле
Добавлено:
1.  Диалог с пользователем по выбору папки для сохранения файлов ответов, стартует сразу после диалога выбора папок с файлами.
2.  После анализа файлов ASX и формирования таблицы ответов файл сохраняется и закрывается.
Сохранение выполняется в указанную папку пользователем с  уникальным именем для исключения наложений и уничтожения предыдущих файлов.
3.  Во время анализа файлов m3u и формирования таблицы ответов файл сохраняется после каждой дозагрузки таблицы,  закрывается.
Сохранение выполняется в указанную папку пользователем с  уникальным именем для исключения наложений и уничтожения предыдущих файлов.
4.  Добавлено уведомление исполнения с возможностью отмены процедуры во время анализа файлов m3u.
5.  Добавлена стартовая кнопка в файле.

Пользуйтесь.
Зачитать и сохранить плейлисты
 
Цитата
Acid Burn написал:
Да, теперь столбец есть, но пока что пустой. )
Я так понимаю данный столбец для пользователя, чтобы вносить свои правки, замечания и т.д.
Зачитать и сохранить плейлисты
 
Как столбец сделать последним, я уже показал в примере, замена двух строк кода всего.
Я так понял неудобно выбирать файлы вместо папки.
Перепишу часть кода с возможностью выбора папки вместо файлов и сборкой ответа с файлов m3u в одну таблицу файла Ексель.
Удаление дубликатов по столбцу "Ссылка" под вопросом, если найду закономерность и будет время тогда реализую иначе нет.
Изменено: TSN - 24 сен 2020 08:09:25
Зачитать и сохранить плейлисты
 
Цитата
Acid Burn написал:
не хватает столбца "Не классифицировано"
Я его не добавил, не обратил внимание когда читал тех задание. Это легко исправить, где он должен быть?.
Если предположить, что это последнее поле таблиц, тогда в
строке кода 142 заменить текст на ReDim arr(1 To (iMaxRow / 2) + 1, 1 To 8
дописать строку 146 (она сейчас пустая)   arr(i,8) = "Не классифицировано"
Код
' переопределение массива и формирование шапки
  ReDim arr(1 To (iMaxRow / 2) + 1, 1 To 8)
  i = 1
  arr(i, 1) = "Источник": arr(i, 2) = "Категория": arr(i, 3) = "Название"
  arr(i, 4) = "Ссылка":  arr(i, 5) = "Сервер":  arr(i, 6) = "Обложка":  arr(i, 7) = "Статус"
  arr(i, 8) = "Не классифицировано"


Я специально сделал так, чтобы каждый файл m3u8 собирался в отдельную книгу и таблицу. Данных много в обрабатываемом файле, если их собрать в одно целое сразу, будет тормозить выполнение процедуры, возможно с зависанием компа. В примерах файлы m3u8 по итогу выгружали таблицу на 10000 строк, если запустить анализ 100 файлов, таблица ответа будет 1000000 строк примерно, что очень тяжело для ексель. Хотя при желании можно сделать дозагрузку ответов в уже имеющуюся таблицу.
Изменено: TSN - 23 сен 2020 15:40:42
Зачитать и сохранить плейлисты
 

Приветствую форумчане.

Давно меня здесь не было, 2 часа пароль вспоминал.

На мой взгляд интересная задачка, решил помочь ТС.

Не пинайте за код, давно не практиковался, решил поразмять мозг немного.

Комментариев к коду мало, только основные моменты, нет достаточного свободного времени.

Кнопку не прикрутил, думаю ТС сможет сам, если нет, то запуск процедуры Alt+F8 в помощь.

Процедура выполняет анализ файлов ASX и m3u8 согласно примера (загруженных файлов плейлисты), каждый проанализированный файл m3u8 выгружается в отдельную книгу EXCEL, файлы ASX собираются в одну таблицу в одной книге. Протестировано на работоспособность в Windows7, Excel 2010, должно работать и в остальных версиях, т.к. функции API не использовались, нестандартные функции не использовались.

В функции GetCollectionM3UfileText лучше использовать регулярные выражения, я в них не силен, текущий код функции возможно будет работать не корректно со всеми файлами m3u8 (ошибки обработки данных).

Процедуры сборки обратно в файл m3u8 не написал.

Код
Код
Public Sub ParserASX_M3U()
'Основная процедура парсинга файлов ASX, m3u8
Dim i As Long, x As Long, n As Long
Dim tmp, temp
Dim arr1(), arr2()
Dim strTemp As String

' Получить коллекцию фалов для обработки.
' Используем внешнюю функцию диалог пользователя открыть файл, _
  дает возможность выбора (обработки) как одного так и всех файлов в папке.
Dim objFilesCollection As Collection
Set objFilesCollection = GetCollectionFilesDialog
If objFilesCollection.Count = 0 Then Exit Sub
' Перебор коллекции поиск фалов ASX и m3u
Dim objASXCollection As New Collection
Dim objM3UCollection As New Collection
For Each tmp In objFilesCollection
  If tmp Like "*.asx" Then
    objASXCollection.Add tmp
  ElseIf tmp Like "*.m3u*" Then
    objM3UCollection.Add tmp
  Else
  End If
Next tmp
Set objFilesCollection = Nothing

' Работаем с файлами ASX
' Считsваем данные файла внешней функцией
If objASXCollection.Count > 0 Then
  arr1 = GetCollectionASXfileText(objASXCollection)
  If LBound(arr1) > 0 Then
    arr1(1, 1) = "TITLE": arr1(1, 2) = "HREF"
    ' Выгружаем данные в новую книгу без сохранения
    Call CreateEXCELfile(arr1, "ASX files", 0)
  End If
End If
' Работаем с файлами m3u8
' Считsваем данные файла внешней функцией
If objM3UCollection.Count > 0 Then
  For Each tmp In objM3UCollection
    strTemp = CreateObject("Scripting.FileSystemObject").GetFileName(tmp)
    arr2 = GetCollectionM3UfileText(tmp)
    If LBound(arr2) > 0 Then
      ' Выгружаем данные в новую книгу без сохранения _
        для каждого файла создается отдельная новая книга
        Call CreateEXCELfile(arr2, strTemp, 1)
    End If
  Next
End If
Set objASXCollection = Nothing
Set objM3UCollection = Nothing
Erase arr1: Erase arr2
End Sub

Private Sub CreateEXCELfile(arrTemp, strNameSht As String, byteDataType As Byte)
''' ЗАГРУЖАЕМ ДАННЫЕ В СОЗДАННУЮ КНИГУ И РАБОТАЕМ С НЕЙ
' byteDataType - тип загружаемых данных (0 = массив файлов ASX, 1 = массив файлов m3u8)
Dim oExcelFile As Object
Dim iMaxRow As Long, iMaxClmn As Long
Dim i As Long, n As Long
iMaxRow = UBound(arrTemp, 1)
iMaxClmn = UBound(arrTemp, 2)

Workbooks.Add -4167 '=xlWBATWorksheet
''' Cоздаем новую книгу с одним листом
With CreateObject("Excel.Sheet"): Set oExcelFile = ActiveWorkbook: End With
With oExcelFile
  ActiveSheet.Name = strNameSht
  With .Sheets(strNameSht)
    ''' Формат ширин полей
    If byteDataType = 0 Then
      For Each oVl In .Range(.Cells(1, 1), .Cells(1, 1).Offset(, iMaxClmn - 1))
        Select Case oVl.Column
          Case Is = 1: oVl.ColumnWidth = 30: Case Is = 2: oVl.ColumnWidth = 145
        End Select
      Next
    ElseIf byteDataType = 1 Then
      For Each oVl In .Range(.Cells(1, 1), .Cells(1, 1).Offset(, iMaxClmn - 1))
        Select Case oVl.Column
          Case Is = 1: oVl.ColumnWidth = 15:  Case Is = 2: oVl.ColumnWidth = 25
          Case Is = 3: oVl.ColumnWidth = 45:  Case Is = 4: oVl.ColumnWidth = 45
          Case Is = 5: oVl.ColumnWidth = 25:  Case Is = 6: oVl.ColumnWidth = 25
          Case Is = 7: oVl.ColumnWidth = 15
        End Select
      Next
    Else
    End If
    ''' Выгружаем данные на лист
    .Range("A1").Resize(iMaxRow, iMaxClmn) = arrTemp '
    ''' Общее форматирование данных на листе
    ''' Форматируем шапку таблицы
    With .Range(.Cells(1, 1), .Cells(1, 1).Offset(, iMaxClmn - 1))
       .HorizontalAlignment = -4108 ' xlCenter
       .VerticalAlignment = -4108   ' xlCenter
       .Interior.Pattern = 1        ' xlSolid
       .Borders.LineStyle = 1       ' xlContinuous
       .Font.Bold = True            ' шрифт жирный
       .WrapText = True             ' перенос текста в ячейке
       .Interior.ColorIndex = 35
       .AutoFilter
    End With
    .Cells(2, 1).Select:  ActiveWindow.FreezePanes = True ''' Закрепить область на второй строке
    ''' Форматируем общие форматы таблицы
    With .Range(.Cells(2, 1), .Cells(iMaxRow, iMaxClmn))
        .HorizontalAlignment = -4131 'xlLeft
        .VerticalAlignment = -4108
        .Borders.LineStyle = 1
        .Interior.ColorIndex = -4105
        .WrapText = False
        .Font.Bold = False
        .Rows.AutoFit
        .Locked = True
    End With
  End With
End With
Erase arrTemp
End Sub

Private Function GetCollectionM3UfileText(strFileName) As Variant
' Функция обрабатывает содержимое файлов ASX возвращая массив
' Источник, Категория, Название, Ссылка, Сервер, Обложка, Статус
Dim oVl, iMaxRow As Long
Dim strLine1 As String, strLine2 As String
Dim arr(), arr1(0, 0), tmp, strTemp, strTemp1
Dim i As Long, n As Long

' Загрузка данных из файла в коллекции, считываем весь текс _
  Используется UTF8 для коррекктного чтения данных
  With CreateObject("ADODB.Stream")
    .Charset = "utf-8": .Mode = 3: .Type = 1
    .Open
    .LoadFromFile strFileName
    .Position = 0: .Type = 2
    strTemp = .ReadText
    oVl = Split(strTemp, vbCrLf)
    iMaxRow = UBound(oVl)
    .Close
    strTemp = vbNullString
  End With
  strFileName = CreateObject("Scripting.FileSystemObject").GetFileName(strFileName)
  ' переопределение массива и формирование шапки
  ReDim arr(1 To (iMaxRow / 2) + 1, 1 To 7)
  i = 1
  arr(i, 1) = "Источник": arr(i, 2) = "Категория": arr(i, 3) = "Название"
  arr(i, 4) = "Ссылка":  arr(i, 5) = "Сервер":  arr(i, 6) = "Обложка":  arr(i, 7) = "Статус"
    
  For n = 1 To iMaxRow Step 2
    If oVl(n) Like "*EXTINF*" Then
      i = i + 1
      strTemp = Split(oVl(n), ",", -1, 1)
      '"Источник"
      arr(i, 1) = strFileName
      '"Категория"
        strTemp(0) = Replace(strTemp(0), "#EXTINF:-1 group-title=", "", 1, -1, 1)
        strTemp(0) = Replace(strTemp(0), Chr(34), "", 1, -1, 1)
        
        If strTemp(0) Like "*tvg-logo*" Then
          strTemp1 = Split(strTemp(0), "tvg-logo=", -1, 1)
          arr(i, 2) = Trim(strTemp1(0))
          '"Обложка"
          arr(i, 6) = Trim(strTemp1(1))
        Else
          arr(i, 2) = Trim(strTemp(0))
          arr(i, 6) = "-"
        End If
      '"Название"
      If strTemp(1) Like "*===*" Then strTemp(1) = Replace(strTemp(1), "=", "", 1, -1, 1)
      arr(i, 3) = strTemp(1)
      ' "Ссылка"
      If oVl(n + 1) Like "*http*" Then arr(i, 4) = oVl(n + 1)
      ' "Сервер"
        strTemp = Split(oVl(n + 1), "/", -1, 1)
        arr(i, 5) = strTemp(2)
      
      ' "Статус"
      arr(i, 7) = "I don't know"
      
    End If
  Next n
Erase oVl: oVl = Empty
strFileName = vbNullString
If i > 0 Then GetCollectionM3UfileText = arr Else GetCollectionM3UfileText = arr1
Erase arr
End Function

Private Function GetCollectionASXfileText(objColl As Object) As Variant
' Функция обрабатывает содержимое файлов ASX возвращая массив
Dim strBuf As String, intFreeFile As Long, Lines() As String
Dim strLine1 As String, strLine2 As String
Dim arr(), arr1(0, 0), tmp, temp
Dim i As Long, n As Long
ReDim arr(1 To objColl.Count + 1, 1 To 2): n = 1
For Each tmp In objColl
  intFreeFile = FreeFile
  Open tmp For Binary As #intFreeFile
  strBuf = Space(LOF(intFreeFile))
  Get #intFreeFile, , strBuf
  Close #intFreeFile
  Lines = Split(strBuf, vbCrLf)
  strBuf = vbNullString
    For i = 0 To UBound(Lines)
      If Lines(i) Like "*<TITLE>*" Then
        Lines(i) = Replace(Lines(i), "<Entry>", "", 1, -1, vbTextCompare)
        Lines(i) = Replace(Lines(i), "<TITLE>", "", 1, -1, vbTextCompare)
        Lines(i) = Replace(Lines(i), "</TITLE>", "", 1, -1, vbTextCompare)
        Lines(i) = Trim(Lines(i))
        strLine1 = Lines(i)
      ElseIf Lines(i) Like "*<ref*" Then
        Lines(i) = Replace(Lines(i), "<ref HREF=", "", 1, -1, vbTextCompare)
        Lines(i) = Replace(Lines(i), "/>", "", 1, -1, vbTextCompare)
        Lines(i) = Replace(Lines(i), Chr(34), "", 1, -1, vbTextCompare)
        Lines(i) = Trim(Lines(i))
        strLine2 = Lines(i)
      Else
      End If
    Next i
    If Len(strLine1) > 0 And Len(strLine2) > 0 Then
      n = n + 1
      arr(n, 1) = strLine1: arr(n, 2) = strLine2
    End If
    strLine1 = vbNullString: strLine2 = vbNullString
Next
If i > 0 Then GetCollectionASXfileText = arr Else GetCollectionASXfileText = arr1
Erase arr
End Function

Private Function GetCollectionFilesDialog() As Collection
''' Функция диалога выбора файлов FileDialog(msoFileDialogFilePicker)
''' Возвращает коллекцию файлов выбраных пользователем
Dim objColl As New Collection
Dim intSelectFile As Long
Dim strMyDocuments
strMyDocuments = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\"
  With Application.FileDialog(3)
      .AllowMultiSelect = True
      .Title = "Выбрать файлы ASX, m3u8 для обработки"
      .Filters.Clear
      .Filters.Add "All files", "*.*", 1
      .Filters.Add "ASX files", "*.asx", 2
      .Filters.Add "m3u8 files", "*.m3u8", 3
      .FilterIndex = 3
      .InitialFileName = strMyDocuments & "*.*.*.*"
      .InitialView = 2
      If .Show = 0 Then
        Set GetCollectionFilesDialog = objColl
        Exit Function
      End If
      'цикл по коллекции выбранных в диалоге файлов, считываем полный путь к файлу
      For intSelectFile = 1 To .SelectedItems.Count
          objColl.Add .SelectedItems(intSelectFile)
      Next
      Set GetCollectionFilesDialog = objColl
  End With
End Function



Пользуйтесь.

Отпишите помогло или как ?

Изменено: TSN - 23 сен 2020 14:58:16
Вставка текста из txt в ячейку
 
Цитата
valentinM написал:
Добрый день!
Искал повсюду ответ на простой вопрос и очень странно - не нашёл!
Плохо искали в каждой книге по VBA есть примеры работы с текстовыми файлами.
Если лень читать книги, то вот Вам пример разберетесь самостоятельно (это всего 1 вариант из десятков возможных).
Удачи
Код
Sub ReadTextFileFSO()
'''Чтение всего текстового файла
Dim objFile As Object, objFS As Object
Dim strFullFileName As String '' полный путь к файлу
Dim strRead As String
strFullFileName = "D:\Users\TSN\Desktop\WWWList.txt"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFile = objFS.OpenTextFile(strFullFileName, 1, True)
    strRead = objFile.ReadAll ''' копируем
              objFile.Close
   ActiveCell.Value = strRead ''' вставляем
Set objFS = Nothing: Set objFile = Nothing
strRead = vbNullString
End Sub
Изменено: TSN - 26 май 2017 15:40:09
Переменная не исчезающая при закрытии книги.
 
1. Можно создать лист Sheet.Visible = xlVeryHidden  супер скрытым и загружать туда данные, после открытия получать их оттуда.
2. Можно выгружать данные в другой файл например в тектовый *.txt, в файл *.xml и так далее
Макрос вставки в текущую ячейку ссылки на файл
 
Цитата
Sege написал:
Можно чтобы ссылка вставлялась в ТЕКУЩУЮ активную ячейку?
Измените процедуру на такую, будет вставлять в выделенную ячейку а также в выделенные ячейки
Код
Sub OpenDialog()
''' Процедура формировани гиперссылки на файл
Dim strAddres As String, Vl
strAddres = fnOpenTextFile
If Len(strAddres) > 0 Then
    For Each Vl In Selection  
      Vl.Value = "=HYPERLINK(" & Chr(34) & strAddres & Chr(34) & "," & Chr(34) & strAddres & Chr(34) & ")"
    Next
End If
End Sub
Изменено: TSN - 26 май 2017 13:44:34
Макрос вставки в текущую ячейку ссылки на файл
 
Ловите решение, тестируйте. В прикрепленном файла также есть код.
Диалог с пользователем специально выведен в отдельную функцию с целью использования ее в других задачах.
Код
Option Explicit

Sub OpenDialog()
''' Процедура формировани гиперссылки на файл
Dim strAddres As String
strAddres = fnGetOpenFilename
If Len(strAddres) > 0 Then
''' Загрузка выполняется в текущую книгу листа1 ячейки А2
  With ThisWorkbook
    With .Sheets("Лист1")
        .Range("A2") = "=HYPERLINK(" & Chr(34) & strAddres & Chr(34) & "," & Chr(34) & strAddres & Chr(34) & ")"
    End With
  End With
End If
End Sub

Public Function fnGetOpenFilename(Optional sTitle As String = "Выбор файла для формирования гиперссылки", _
                                  Optional MultiSelectFiles As Boolean = False)
''' Функция диалога с пользователем выбора файла _
 по умолчанию выбор любого формата файла, выбор только одного файла
  fnGetOpenFilename = Application.GetOpenFilename _
                  ("Любые файлы (*.*),*.*", , sTitle, , MultiSelectFiles)
End Function
Изменено: TSN - 26 май 2017 13:16:53
сбор данных с файлов, заполнение сводной таблицы с разных файлов
 
Правила форума  
2.2. Опишите максимально подробно вашу задачу
и желаемый результат. Желательно уточнить вашу версию Excel.
   2.3. Приложите файл(ы) с примером (общим весом не более 100 Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
Изменено: TSN - 23 май 2017 16:46:05
VBA не видит если дата расчитана формулой
 
Измените вашу процедуру на такой вариант и будет Вам счастье
Код
Sub ZapolnitDanie2()
Dim X As String, X1 As Date, X2 As Range, X3 As Integer, X4 As Integer
Dim rngBase As Range, rngIcells As String
'_______________________________ на какую дату делаем заполнение ___________________________________________
X1 = Range("S6").Text 'берем дату для определения заполняемой колонки
Set X2 = Range("A4:G4")
For Each vl In X2.Cells
  If vl.Text = X1 Then vl.Select: Exit For 'выделяем и выходим из цикла
Next
End Sub
Условное форматирование или макрос если ячейка не содержит, Покрасить ячейки с непечатными символами
 
замените в коде
Код
objRegExp.Pattern = "[^А-я0-9_\,\ \-]"
на
Код
objRegExp.Pattern = "[^А-я0-9_\,\ \-\/\\\[]"
Условное форматирование или макрос если ячейка не содержит, Покрасить ячейки с непечатными символами
 
Еще один вариант решения
Процедура анализирующая диаппазон ячеек активной книги. активного листа (ActiveWorkbook.ActiveSheet).
Анализируемый диаппазон 20 ячеек в данном случае при желании можно менять .Range("A1:A20") или .Range("A1:B20") или .Range("A1:H2000") и тд.
Также можно использовать .Range("A1").CurrentRegion и ActiveSheet.UsedRange или Selection всё зависит от поставленных задач.
Тестируйте.
Код
Sub Покрасить_ячейки_с_непечатными_символами()
Dim objRegExp, Vl
Set objRegExp = CreateObject("VBScript.RegExp") 
objRegExp.Global = False
objRegExp.IgnoreCase = True            ' Игонорируем регистр
objRegExp.Pattern = "[^А-я0-9_\,\ \-]" ' Не входит в шаблон (сравниваемый текст) "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩ­ЪЫЬЭЮЯ0123456789 ._-"
With ActiveWorkbook
  With .ActiveSheet
      For Each Vl In .Range("A1:A20")  ''' Анализ 
        If objRegExp.test(Vl.Value) Then Vl.Interior.Color = 255
      Next
  End With
 End With
Set objRegExp = Nothing
End Sub
Изменено: TSN - 23 май 2017 15:13:18
Простое двойное условие, если активная ячейка пустая
 
Вот реализация Вашего желания в реальности пользуйтесь, тестируйте, могут быть баги писал в блокноте. Логику можно еще более навернуть, возможности VBA позволяют.  :)
Обратите внимание процедура заточена под активное приложение Excel и активный лист (With ActiveWorkbook,  With ActiveSheets)  8)
Код
Sub Удалить_проект_Несколько()
Dim Vl, intCount As Long, intTest
With ActiveWorkbook
  With ActiveSheets
    If Intersect(ActiveCell, Columns(2)) Is Nothing Then ''' Если выделение вне столбца "Б"
       MsgBox "Выберете ячейку с названием проекта в колонке B и повторите действие еще раз", 48
    Else
      For Each Vl In Selection  ''' Анализ количества выделенных ячеек только столбца "Б"
        intCount = intCount + 1
        If Not IsEmpty(Vl.Value) And Vl.Column = 2 Then intTest = intTest + 1
      Next
      Select Case intCount
      Case Is = 1 ''' стандартная обработка одной ячейки
          Select Case intTest
            Case Is = 0: MsgBox "Данные о проектах полностью удалены", 64
            Case Else
               If MsgBox("Данные этого проекта будут полностью удалены. Продолжить?", 4) = 6 Then ActiveCell.Value = Empty
          End Select
      Case Else   ''' расширенная обработка нескольких ячеек
        Select Case intTest
          Case Is = 0: MsgBox "Данные о проектах полностью удалены", 64
          Case Else
             If MsgBox("Общее количество выделенных ячеек проектов колонки Б составило " & intTest & "штук. Продолжить?", 4) = 6 Then
                For Each Vl In Selection ''' Удаляем выделенные ячейки только столбца "Б"
                    If Not IsEmpty(Vl.Value) And Vl.Column = 2 Then Vl.Value = Empty
                Next
             End If
          End Select
      End Select
    End If
  End With
 End With
End Sub
VBA готовые классы для создания древовидной структуры
 
dsb75, Ваш труд впечатляет, конечно возможностей Collection / Dictionary / NET 2.0 (System.Collections.ArrayList) вполне хватает. Но с целью изучения Вашего кода и самообразования в мире VBA  в ближайший проект с удовольствием добавлю класс PerfectTree.

Большое спасибо за труд.

Подсчет количества числовых строк в массиве
 
Цитата
Tidus написал:
А если всё делать в памяти внутри кода, то к коде из 1000 строк гораздо сложнее найти ошибку в формулах, чем в таблице, где все данные на виду.
Уважаемый Tidus касательного вашего примера, код который выполняет действия согласно Вашего примера менее 1000 строк, конечно его можно усложнить при желании.
Код
Sub КоличествоСтрок_с_Числами()
Dim rng As Range, vl, temp, i  As Long, Summ As Long
Const ClmnCount As Long = 3 'констатнта количество столбцов (полей) в массиве
With ThisWorkbook
  Set rng = .Sheets("Лист1").Range("b4:b14") 'диаппазон первого поля массива
  For Each vl In rng
    For i = 0 To ClmnCount - 1 'анализ массива (поиск чиловых значений)
      temp = .Sheets("Лист1").Cells(vl.Row, vl.Column + i).Value
      If Not IsEmpty(temp) Then If IsNumeric(temp) Then Summ = Summ + 1: Exit For
    Next i
  Next
End With
Set rng = Nothing 'финальная стадия. очистка памяти вывод результата
MsgBox "Результат = " & Summ, vbInformation, "ОТВЕТ"
End Sub

Изменено: TSN - 22 май 2017 17:05:16
Выбор из таблиц значений в зависимости от номера строки
 

Сори недосмотрел  :)

Все равно предложу альтернативу  ;)

Дело в том, что ReDim Preserve arr(1 To 4, 1 To h) внутри цикла замедляет выполнение процедуры. Для быстродействия лучше вычислить размер итогового массива до цикла (конечно если это возможно), так будет быстрей работать, конечно при цикле в 491 строку и 4 поля это незаметно, но если запустить обработку скажем 900000 строк и 25 полей массива ReDim Preserve однозначно проявит себя. 8)

Код
Option Explicit

Sub TempCopy11()
Dim arr(), arrItog()
Dim maxRow As Long, maxClmn As Long
Dim i As Long, x As Long, n As Long

With ThisWorkbook
    ''' Загрузка массива с шагом в 10 строк
    arr = .Sheets("Лист1").Range(.Sheets("Лист1").Cells(1, 1).End(xlToRight), .Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp)).Value
    maxRow = UBound(arr, 1): maxClmn = UBound(arr, 2)
    ReDim arrItog(1 To maxRow / 10 + 1, 1 To maxClmn)
    
    For i = 1 To maxRow Step 10
    n = n + 1
      For x = 1 To maxClmn
         arrItog(n, x) = arr(i, x)
      Next x
    Next i
    
    ''' Выгрузка массива ответа в два разных места
    With Sheets("Лист2")
      .Range("A1").Resize(UBound(arrItog, 1), UBound(arrItog, 2)) = arrItog
    End With
    On Error Resume Next
    .Worksheets.Add.Name = "List12345"
    With Sheets("List12345")
      .Range("A1").Resize(UBound(arrItog, 1), UBound(arrItog, 2)) = arrItog
    End With
    Erase arr: Erase arrItog
End With
End Sub
Выбор из таблиц значений в зависимости от номера строки
 
Для ознакомления с возможностями VBA, VBA Excel.
Еще несколько способов копирования данных (таблиц и т.д.). Процедура написана под ваш пример сделать копию таблицы.
Код
Sub TempCopy()
Dim objTemp As Object
Dim maxRow As Long, maxClmn As Long

With ThisWorkbook
  With Sheets("Лист1")
    ''' Вариант 1
    Set objTemp = .Range(.Cells(1, 1).End(xlToRight), .Cells(Rows.Count, 1).End(xlUp))
    maxRow = objTemp.Rows.Count
    maxClmn = objTemp.Columns.Count
    objTemp.Copy
'    1.1
    .Paste (.Range(.Cells(1, (maxClmn * 2) + 2), .Cells(maxRow, (maxClmn * 2) + 2)))
'    1.2
    .Paste (Sheets("Лист2").Range(Sheets("Лист2").Cells(1, 1), Sheets("Лист2").Cells(maxRow, 1)))
    Set objTemp = Nothing
    
    ''' Вариант 2 - Выгружаем (копия массива) данные на лист
    Dim arr
    arr = .Range(.Cells(1, 1).End(xlToRight), .Cells(Rows.Count, 1).End(xlUp)).Value
'    2.1
     With Sheets("Лист3")
       .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
     End With
'     2.2
     Worksheets.Add.Name = "List12345"
     With Sheets("List12345")
       .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
     End With
    Erase arr
  End With
End With
End Sub


Вывод данных из Excel текстом
 
Код
Sub Упрощенный_пример()
  Dim sName As String, F, M
  Dim arr(), i As Long, x As Long
  With ThisWorkbook
      sName = .Sheets("Лист1").Range("B1").Value: arr = .Sheets("Лист1").Range("A2:N5").Value
  End With
  F = FreeFile
  Open ThisWorkbook.Path & "\Запись.txt" For Output As #F
  Print #F, Spc(10); sName
  Print #F, ""
  For i = 1 To UBound(arr, 1)
    Print #F, ""
      For x = 1 To UBound(arr, 2): Print #F, arr(i, x) & " ";: Next x
    Next i
  Close #F
End Sub

Простой пример записи данных с листа в текстовый файл без форматирования. При желании можно формировать отчеты в любые форматы файла (*.txt; *.doc; *.xls; *.csv; *.html) и так даллее.
Почитайте внимательно правила форума и подготовьте вопрос согласно требований, правила не даром написаны.
Вывод данных из Excel текстом
 
Цитата
Валерик написал: Над Вами тоже все стебаются, когда Вы что-то не знаете и просите помощи?
Уважаемый я не стебаюсь. Ваш вопрос привел меня к такому ответу.
Если вопрос будет конкретней то ответ будет конкретней.
Вывод данных из Excel текстом
 
Цитата
vbandurko написал:
Требуется ежедневно выуживать
Для этого лучше подойдет удочка, спининг или сеть
Цитата
vbandurko написал:
Далее по моей задумке нужно присвоить переменной все эти данные с помощью значков & и оператора Chr(10)
Лучше с помощью крючков.
:D :D :D
Как производить арифметические действия с адресом ячейки в макросе
 
Так будет работать
Код
Sub Макрос()
Dim sFind, iRange, adr
With ThisWorkbook
  With Лист1
  sFind = .Cells(2, 2).Value                      '''ссылка на ячейку В2 со занчением для поиска
    With .Range(.Cells(1, 1), .Cells(100, 1))     ''' поиск в заданном диаппазоне А1:А100
      Set iRange = .Find(What:=sFind, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) '''ссылка на найденую ячейку со занчением
      If Not iRange Is Nothing Then
        MsgBox "адрес " & iRange.Address & vbCrLf & "значение = " & iRange.Value
      Else
        MsgBox "Поиск не дал результат"
      End If
    End With
  End With
End With
End Sub
Страницы: 1 2 3 4 5 6 7 След.
Наверх