Сообщения

Т.е. после выполнения этой команды, получается уже можно использовать добавление новой строки (.AddItem) и как обычно работать со номерами столбцов > 10?

Попробовать самостоятельно не получается? Нужно какое-то отдельное подтверждение? Если честно - думал, что специально проставленный комментарий вполне красноречиво описывает эту возможность 

Пример совершенно не информативный, т.к. не к чему хоть что-то привязать и понять, что откуда Вы собираетесь записывать в ListBox. Данных-то вообще нет - пустой лист. По коду тоже нет понимания, что откуда планируется записывать.
Грубо вот как-то так - под пример сами подстраивайте:

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

  cols = 15               ' кол-во столбцов
  ReDim Arr(0, 1 To cols) ' создаем массив с одной строкой и нужным количеством столбцов
  With ListBox1
    .ColumnCount = cols
    .List = Arr()    ' если назначить в качестве данных даже пустой массив - это позволит дальше работать с кол-вом столбцов > 10
    For r = 2 To 20 'цикл по строкам
      If Cells(r, 1) = "некое условие" Then
        .AddItem Empty
        For c = 1 To cols
          .List(i, c-1) = Cells(r, c).Value
        Next
        i = i + 1
      End If
    Next
    .RemoveItem .ListCount - 1  'Удаляем строку, которая использовалась для трюка с добавлением более 10-ти столбцов
  End With

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

Sub GetDateColor()
    Dim ws As Worksheet
    Dim dicDates As Object
    Dim llastr&, lr&, lcolor&
    Dim dt As Date
    Dim s$, scolor$
   
    Set ws = ActiveSheet
    Set dicDates = CreateObject("Scripting.Dictionary")
    dicDates.comparemode = 1
    With ws
        llastr = .Cells(.Rows.Count, "I").End(xlUp).Row
        For lr = 2 To llastr
            dt = .Cells(lr, 9).Value
            lcolor = .Cells(lr, 2).Font.Color
            If dt > 0 Then
                Select Case lcolor
                Case 255 'red
                    scolor = "красный"
                Case 5287936 'green
                    scolor = "зеленый"
                End Select
                If Not dicDates.Exists(dt) Then
                    dicDates.Add dt, scolor
                Else
                    If dicDates.Item(dt) <> scolor Then
                        dicDates.Item(dt) = "двойственная"
                    End If
                End If
            End If
        Next
    End With
   
    If dicDates.Count Then
        ws.Range("O2").Resize(dicDates.Count, 1).Value = Application.Transpose(dicDates.keys)
        ws.Range("N2").Resize(dicDates.Count, 1).Value = Application.Transpose(dicDates.items)
    End If
End Sub

Вы бы приложили файл с данными и описали бы задачу применительно к нему. Здесь, на форуме. Глядишь и бесплатно ответ получите Т.к. судя по описанию код не выглядит сложным.

Так все правильно - если выводит сообщение, что ячейка не зеленая - то allGreen будет False и соответственно этот блок будет пропущен:

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

If allGreen Then

Я бы понял, и не такое понимали

ну да, ну да
Тогда вопрос: а обязательно вставлять именно как мета-файл? В этом есть какой-то определенный смысл? Не пробовали вставлять как Shape, например? Вставляется не вся информация или это просто недопустимо?

При чём тут имитация ПКМ?

вот при чём:

если нажать ПКМ и выбрать Изменение рисунка - становится видимым полностью и при конвертации в инлайн остаётся полным. Как это выполнить на VBA?

Вы бы сами поняли себя, если бы так поставили задачу? Описали кучу действий и только один вопрос: как это выполнить. Я и задал первым делом вопрос: что именно "это"? И дальше уже стал описывать, какие варианты понимания задачи появляются при подобной их постановке.

Насчет команды "Изменить изображение". У меня её вообще нет - все действия по редактированию выполняются с панели при выделенном изображении. Да я и не помню, чтобы такая команда была. Изменить изображение появляется один раз - при вставке изображения. В дальнейшем его можно заменить или изменять свойства и параметры через панель.
Вам точно надо именно "Изменить изображение"? Какова конечная цель выполнения этой команды? Может быть можно найти другие пути решения - если знать, что именно искать.

Как это выполнить на VBA

Это - это что? ПКМ по рисунку? Конвертирование? Конкретизируйте. Картинка не подгружается и что Вы там делаете и что надо вообще непонятно.
Конвертировать: h.ConvertToInlineShape
ПКМ - нельзя имитировать простыми средствами, там надо через API заморачиваться. Проще докопаться до причины. Возможно глюк или неполная прорисовка сразу после вставки и нужно время(тот же цикл от 1 до 100 с DoEvents)

линии не переносятся

сделали бы на листе ФИЛЬТР эти линии через границы ячеек, а не фигурами - тогда и лишних телодвижений не потребовалось бы.
Ну а без этого - можно накрутить лишнего(что не всегда хорошо):

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

Sub iSort_()
Dim Itog As Worksheet, wsFilter As Worksheet
Dim iLastRow As Long
Dim i As Long
Dim sh As Shape
  Set wsFilter = ActiveSheet
  Set Itog = ThisWorkbook.Worksheets("Итог")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    With Itog
      .Cells.Clear
      .DrawingObjects.Delete
      wsFilter.Range("A1:J" & iLastRow + 1).Copy .Cells(1, 1)
      .Cells.UnMerge
      .Cells.Value = Empty
      wsFilter.Range("A1:J" & iLastRow + 1).Copy
      .Cells(1, 1).PasteSpecial xlPasteValues
      .Cells(1, 1).PasteSpecial xlPasteFormats
      Application.CutCopyMode = False
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
      .Range("A22:J" & iLastRow).Sort Key1:=.Range("F4"), Order1:=xlAscending, Header:=xlYes
'        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
       
        .Range("A23") = 1
        .Range("A23").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=iLastRow - 22, Trend:=False

       
        For i = iLastRow To 23 Step -1
        If IsDate(.Cells(i - 1, "F")) Then
          If Month(.Cells(i, "F")) <> Month(.Cells(i - 1, "F")) Then
            .Rows(i).Insert
            .Range("A" & i & ":J" & i).Merge
            .Range("A" & i).HorizontalAlignment = xlCenter
            .Range("A" & i) = Format(.Cells(i + 1, "F"), "MMMM")
          End If
        End If
        Next
            .Range("A23").EntireRow.Insert
            .Range("A23 :J23").Merge
            .Range("A23 :J23").HorizontalAlignment = xlCenter
            .Range("A23 :J23") = Format(.Cells(24, "F"), "MMMM")
    End With
End Subда, заменил цикл по фигурам на одну строку удаления - цикл лишний, от слова совсем, да еще с Like на любую строку.

Попробуйте заменить эту строку:

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

Range("A1:J" & iLastRow).Copy .Cells(1, 1)на такие:

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

Range("A1:J" & iLastRow).Copy
.Cells(1, 1).PasteSpecial xlPasteValues
.Cells(1, 1).PasteSpecial xlPasteFormats
Application.CutCopyMode = false

подсказки не появляются

у меня появляются. Наводите на иконку, ждете секунду - всплывает подсказка.

Kuzmich - Коды оформляйте тегами Code(Код). п.п. 4.25 Правил форума.
Я не могу постоянно делать это за Вас

Можете написать мне в личные сообщения на форуме или через форму заказа на сайте: Заказ на разработку
Задачу тогда надо будет обсуждать более детально, прежде чем начать разработку.

Там почти все править надо. Возьмите код из ссылки, которую я выше скидывал. Там код как раз берет и файлы в папке и в подпапках. А в приложенном Вами - только в одной папке.
А сама ошибка означает, что некорректное имя файла. Возможно, проблема в том, что Вы пытаетесь перебрать все файлы, а не только файлы Excel. А там могут быть и временные, и скрытые, и системные.

Вместо этого куска:

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

On Error Resume Next
        appExcel.Workbooks.Open fullPath
        If Err.Number <> 0 Then
            newName = "ПОДОЗРИТЕЛЬНЫЙ_ФАЙЛ_" & fileName
            fso.MoveFile fullPath, folderPath & newName
            Err.Clear
        Else
            appExcel.ActiveWorkbook.Close
        End Ifпопробуйте вот такой:

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

On Error Resume Next
set wb = Nothing
set wb = appExcel.Workbooks.Open(fullPath)
If wb is Nothing Then
    newName = "ПОДОЗРИТЕЛЬНЫЙ_ФАЙЛ_" & fileName
    fso.MoveFile fullPath, folderPath & newName
    Err.Clear
Else
    ws.Close 0
End IfИ где-нибудь вверху добавьте объявление:

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

Dim wb As Object
И не забывайте оформлять коды соответствующими тегами.