Сообщения

Судя по всему, у вас при активации поиска открывается какая-то форма, на которой есть поле TextBox для ввода кода. Можно  попробовать повесить TextBox1.Value = "" на событие UserForm_Initialize или UserForm_Activate, или в конец вашего кода с поиском... В зависимости что у вас там происходит.

Вот что пишут в интернетах:
На macOS использование VBA для автоматизации браузера через `InternetExplorer.Application` невозможно, так как это Windows-специфичная технология (COM-объект). Вот рабочие альтернативы для парсинга сайтов на Mac:
### 1. **Использование AppleScript + Safari (для динамических сайтов)**
Автоматизируйте Safari через AppleScript, чтобы получить HTML-код страницы.

**Пример в VBA:**

Код Выделить Развернуть

```vba
Sub ParseWithSafari()
    Dim script As String
    ' AppleScript для получения HTML через Safari
    script = "tell application ""Safari""" & vbCrLf & _
             " activate" & vbCrLf & _
             " tell current tab of window 1" & vbCrLf & _
             " set URL to ""https://example.com""" & vbCrLf & _
             " delay 3 ' Ждем загрузки страницы" & vbCrLf & _
             " return do JavaScript ""document.documentElement.outerHTML""" & vbCrLf & _
             " end tell" & vbCrLf & _
             "end tell"
   
    ' Выполняем AppleScript из VBA
    Dim result As String
    result = MacScript(script)
   
    ' Выводим результат (далее можно парсить)
    Debug.Print result
End Sub
### 2. **HTTP-запросы через `XMLHTTP` (для статических страниц)**
Используйте объект `XMLHTTP` для GET/POST-запросов (работает без открытия браузера).

**Пример в VBA:**

Код Выделить Развернуть

```vba
Sub GetWebsiteContent()
    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP")
   
    http.Open "GET", "https://example.com", False
    http.Send
   
    ' Получаем HTML
    Dim html As String
    html = http.responseText
   
    Debug.Print html
End Sub
```**Примечание:** Если `MSXML2.XMLHTTP` недоступен, попробуйте `Microsoft.XMLHTTP`.

### 3. **Использование Python (рекомендуется для сложных задач)**
Запустите Python-скрипт из VBA для парсинга (например, с помощью `requests` и `BeautifulSoup` или `Selenium`).

**Шаги:**
1. Установите Python и библиотеки:

Код Выделить Развернуть

   ```bash
   pip install requests beautifulsoup4 selenium
   ```
2. Создайте Python-скрипт (`parser.py`):

Код Выделить Развернуть

   ```python
   from bs4 import BeautifulSoup
   import requests

   url = "https://example.com"
   response = requests.get(url)
   soup = BeautifulSoup(response.text, 'html.parser')
   print(soup.prettify()) # или извлеките нужные данные
   ```
3. Вызовите скрипт из VBA:

Код Выделить Развернуть

   ```vba
   Sub RunPythonScript()
       Dim result As String
       result = MacScript("do shell script ""python3 /path/to/parser.py""")
       Debug.Print result
   End Sub
   ```
### 4. **Selenium WebDriver (для JavaScript-сайтов)**
Настройте Selenium с браузером (Chrome/Firefox) и управляйте им через Python.

**Пример Python + Selenium:**

Код Выделить Развернуть

```python
from selenium import webdriver

driver = webdriver.Safari() # или Chrome/Firefox
driver.get("https://example.com")
html = driver.page_source
print(html)
driver.quit()
```
### Итог:
* Для простых запросов — `XMLHTTP`.
* Для динамических сайтов — **AppleScript + Safari**.
* Для сложных задач — **Python** (лучший вариант на macOS).

Краткий **чеклист** для выбора подхода:

### 🚀 **Что дальше?**
1. **Нужен быстрый парсинг без браузера?** → Используйте `XMLHTTP` в VBA или Python c `requests`.
2. **Сайт полагается на JavaScript?** → Выбирайте **Selenium** (Python) или **AppleScript + Safari**.
3. **Хотите максимум гибкости?** → Переходите на Python (`BeautifulSoup`, `Selenium`, `Scrapy`).
4. **Нужна помощь с настройкой?** → Готов расписать шаги по установке библиотек или отладке скриптов.

Например, можно быстро **собрать данные с сайта на Python** даже без VBA. Вот мини-гайд:

Код Выделить Развернуть

```python
# Установите библиотеки (если еще не):
# pip install requests beautifulsoup4

import requests
from bs4 import BeautifulSoup

url = "https://example.com"
response = requests.get(url)
soup = BeautifulSoup(response.text, 'html.parser')
# Пример: получить все заголовки h1

Код Выделить Развернуть

titles = soup.find_all('h1')
for title in titles:
    print(title.text)
```

Если раньше всё было хорошо, то, может, дело не в программе, а в каких-то обновлениях ОС или офиса. Как вариант - откатить обновления винды и офиса до даты начала проблем, посмотреть, что будет.

Проблема решена, код прилагаю. Думаю, добавлю ещё в него статус-бар, т.к. при обработке 500-700 файлов он будет очень полезен для наглядности процесса.

Код Выделить Развернуть

Sub MergeTablesFromMultipleWorkbooks()
    Dim targetSheet As Worksheet
    Dim sourceFolder As String
    Dim sourceFile As String
    Dim sourceWorkbook As Workbook
    Dim sourceRange As Range
    Dim visibleData As Range
    Dim lastRow As Long
    Dim firstFile As Boolean
    Dim startRow As Long
    Dim fileName As String
   
    ' Настройки
    Set targetSheet = ThisWorkbook.Sheets("Объединенные данные")
    sourceFolder = GetFolderPath()
    If sourceFolder = "" Then Exit Sub
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    firstFile = True
    sourceFile = Dir(sourceFolder & "\*.xls*")
   
    ' Инициализация целевого листа
    targetSheet.Cells.Delete
    targetSheet.Range("A1").Value = "Источник файла"
   
    Do While sourceFile <> ""
        If sourceFile <> ThisWorkbook.Name Then
            Set sourceWorkbook = Workbooks.Open(sourceFolder & "\" & sourceFile)
            fileName = Split(sourceFile, ".")(0)
           
            With sourceWorkbook.Sheets("Расчет суммы кредита") 'ТУТ ИМЯ ВАШЕГО ЛИСТА
                ' Снятие защиты листа с проверкой
                On Error Resume Next
                .Unprotect Password:="-П А Р О Л Ь-" ' Укажите ваш пароль если известен или закомментируйте блок
                On Error GoTo 0
               
                ' Проверка на пустой файл
                lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                If lastRow < 1 Then
                    MsgBox "Файл " & sourceFile & " пуст", vbExclamation
                    GoTo CloseWorkbook
                End If
               
                Set sourceRange = .Range("A1:k" & lastRow) 'ТУТ УКАЖИТЕ ДИАПАЗОН КОПИРОВАНИЯ
            End With
           
            With targetSheet
                If firstFile Then
                    ' Копируем заголовки как значения
                    sourceRange.Rows(1).Copy
                    .Range("B1").PasteSpecial xlPasteValues
                    firstFile = False
                End If
               
                ' Получаем видимые данные с обработкой ошибок
                On Error Resume Next
                Set visibleData = sourceRange.Offset(1).Resize(sourceRange.Rows.Count - 1) _
                                  .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
               
                ' Проверяем наличие видимых данных
                If Not visibleData Is Nothing Then
                    startRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                   
                    ' Копируем только значения
                    On Error Resume Next
                    .Range("B" & startRow).Resize(visibleData.Rows.Count, visibleData.Columns.Count).Value = _
                        visibleData.Value
                    On Error GoTo 0
                   
                    ' Заполняем колонку с именем файла
                    lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
                    If lastRow >= startRow Then
                        .Range("A" & startRow & ":A" & lastRow).Value = fileName
                    End If
                Else
                    MsgBox "В файле " & sourceFile & " нет видимых данных", vbExclamation
                End If
            End With

CloseWorkbook:
            sourceWorkbook.Close False
            Set visibleData = Nothing
        End If
        sourceFile = Dir()
    Loop
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    ' Форматирование результата
    With targetSheet
        .Rows(1).Font.Bold = True
'        .Columns.AutoFit
        If .Cells(1, 2) = "" Then .Cells(1, 2) = "Нет данных"
    End With
   
    MsgBox "Объединено " & targetSheet.Cells(targetSheet.Rows.Count, 2).End(xlUp).Row - 1 & " строк", vbInformation
End Sub
Function GetFolderPath() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку с исходными файлами"
        .AllowMultiSelect = False
        If .Show = -1 Then
            GetFolderPath = .SelectedItems(1)
        Else
            GetFolderPath = ""
        End If
    End With
End Function

тут есть пример:
https://excel2.ru/articles/trehmernye-diagrammy-poverhnosti-i-izolinii-v-ms-excel?ysclid=m85j6kyf39671438063

Всем привет! На сайте есть супер макрос для сбора данных из нескольких листов/книг:
https://www.excel-vba.ru/chto-umeet-excel/kak-sobrat-dannye-s-neskolkix-listov-ili-knig/comment-page-30/#comment-254645
Я никак не могу доработать его таким образом, чтобы копировались данные только из НЕ скрытых строк. Например (во вложении Книга1 и Книга2) - на листе есть три таблицы, две из которых всегда скрыты. Когда я запускаю макрос сбора данных, указав диапазон = "Область печати", то он копирует всё независимо от того скрыты строки или нет. Пробовал использовать ".SpecialCells(xlCellTypeVisible)" - выдает ошибку "Это невозможно сделать в объединённой ячейке". Пробовал добавить проверку скрытости строк через If

Код Выделить Развернуть

With wsSh
If Range("A3").EntireRow.Hidden = True And Range("A26").EntireRow.Hidden = True Then Set iBeginRange = Range("A58:k73")
If Range("A26").EntireRow.Hidden = True And Range("A58").EntireRow.Hidden = True Then Set iBeginRange = Range("A3:k18")
If Range("A3").EntireRow.Hidden = True And Range("A58").EntireRow.Hidden = True Then Set iBeginRange = Range("A26:k47")работает, но только с первым файлом. На втором выдает ошибку "object requred" по строке "sCopyAddress = iBeginRange.Address"
Просьба помочь гуру форумчан доработать макрос для копирования только видимых строк.
Вы не можете просматривать это вложение.
Вы не можете просматривать это вложение.
Вы не можете просматривать это вложение.