Функция соответствия VBA и вложенные для поиска

У меня есть два листа. Один – это таблица и содержит данные, которые я хочу ввести в другой. Другой выглядит почти как диаграмма Ганта, с именами внизу и датами сверху (см. Здесь ).

Я хочу, чтобы программа выполнялась так, как указано ниже, но запускается как есть, она возвращает:

Ошибка времени выполнения «438»:

Объект не поддерживает это свойство или метод

на

For Each Row1 In Resource 

Я попытался выполнить различные исправления, но каждый раз, когда я настраиваю одну ошибку, я, похоже, вызываю другую!


  1. Проверьте столбец таблицы «Ресурс выделен» и найдите соответствующее имя в первом столбце листа календаря.
  2. Проверьте столбец таблицы «Дата выделенного» и найдите соответствующее значение в первой строке листа календаря.
  3. Выберите ячейку, в которой они пересекаются (ячейка с номером столбца «Дата выделена» и номер строки «Ресурс выделен»).
  4. Смещение номера столбца в соответствии с третьим столбцом таблицы «Время суток».
  5. Заполните ячейку цветом RGB, указанным в коде.
  6. Повторите для каждой строки.

 Option Explicit Sub CalendarSync() Sheets("Log").Select Dim Resource As ListColumn Dim Dates As ListColumn Dim ToD As ListColumn Dim Row1 As ListRow Dim Row2 As ListRow Dim Row3 As ListRow Set Resource = ActiveSheet.ListObjects("Table1").ListColumns("Resource Allocated") Set Dates = ActiveSheet.ListObjects("Table1").ListColumns("Date Allocated") Set ToD = ActiveSheet.ListObjects("Table1").ListColumns("Time of Day") Dim ResMatch As Variant Dim DateMatch As Variant For Each Row1 In Resource 'Cross Referencing Dates & Resources Allocated ResMatch = Application.Match(Resource, Worksheets("Calendar").Columns(1), 0) For Each Row2 In Dates DateMatch = Application.Match(Dates, Worksheets("Calendar").Rows(1), 0) 'Offsetting to Account for Time of Day For Each Row3 In ToD If ToD = "PM" Then DateMatch.ColumnOffset (1) End If If ToD = "EVE" Then DateMatch.ColumnOffset (1) End If 'Fill the Cell Range(ResMatch, DateMatch).Interior.Color = RGB(244, 66, 182) Next Row3 Next Row2 Next Row1 End Sub 

Я сделал некоторые важные изменения в вашем коде. В этом случае функция Match не работает очень хорошо, я думаю, что использование метода Find дает лучший ответ. Посмотрите эти изменения:

 Option Explicit Sub CalendarSync() Dim Resource As Range Dim Dates As Range Dim ToD As Range Dim DateRow As Range Dim DateCol As Range Dim lCol As Range Dim Row1 As Range Dim Row2 As Range Dim Row3 As Range Dim Range As Range Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = ThisWorkbook.Sheets("Log") Set sh2 = ThisWorkbook.Sheets("Calendar") Set Resource = sh1.ListObjects("Table1").ListColumns("Resource Allocated").Range Set Dates = sh1.ListObjects("Table1").ListColumns("Date Allocated").Range Set ToD = sh1.ListObjects("Table1").ListColumns("Time of Day").Range Set lCol = sh2.Cells(1, sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column + 2) Set DateRow = sh2.Range("A1", lCol) 'Set the row range of your dates Set DateCol = sh2.Range("A1", sh2.Range("A" & Rows.Count).End(xlUp)) 'Set the column range of your resources Dim ResMatch As Range Dim DateMatch As Range For Each Row1 In Resource 'Find the Resource match in column Set ResMatch = DateCol.Find(What:=Row1, LookIn:=xlValues) If Not ResMatch Is Nothing Then 'If has found then 'Find the Date match in row Set Row2 = Row1.Offset(0, 1) Set DateMatch = DateRow.Find(What:=Row2, LookIn:=xlValues) If Not DateMatch Is Nothing Then 'If has found then Set Row3 = Row1.Offset(0, 2) If Row3 = "PM" Then Set Range = sh2.Cells(ResMatch.Row, DateMatch.Column).Offset(0, 1) ElseIf Row3 = "EVE" Then Set Range = sh2.Cells(ResMatch.Row, DateMatch.Column).Offset(0, 2) Else Set Range = sh2.Cells(ResMatch.Row, DateMatch.Column) End If Range.Interior.Color = RGB(244, 66, 182) End If End If Next Row1 End Sub 

Как мысль: хотя, конечно, есть способ зациклиться на вашем объекте списка, следующее может быть ближе к тому, что вам нужно:

  • сохранить объект списка
  • прочитайте его в объекте Recordset -объект
  • Recordset вместо списка-объекта

Эта…

  • стирает необходимость в большинстве переменных объекта
  • делает для более читаемого кода (imho), так как вы можете использовать литерал Field.Names
  • настраивается в любой диапазон, содержащий данные, вместо того, чтобы фиксироваться в ListObjects

Вот пример использования набора записей:

 Option Explicit Sub testrecordset() Dim lo As Object Set lo = ThisWorkbook.Sheets(1).ListObjects("LObject1") ' See the f With GetRecordset(lo.Range) ' get all data ' ThisWorkbook.Sheets(2).Cells(2, 1).CopyFromRecordset rs ' get number of records Debug.Print .RecordCount ' add filter ' .Filter = "[Resource Allocated] = 1" ' clear filter ' .Filter = vbNullString ' get headers ' Dim i As Integer: i = 1 ' Dim fld As Object ' For Each fld In .Fields ' ThisWorkbook.Sheets(2).Cells(1, i).Value = fld.Name ' i = i + 1 ' Next fld ' Loop Records/Rows While Not .EOF 'Debug.Print !FirstName & vbTab & !IntValue .MoveNext Wend End With End Sub ' This function will return the data of a range in a recordset Function GetRecordset(rng As Range) As Object 'https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/ Dim xlXML As Object Dim rst As Object Set rst = CreateObject("ADODB.Recordset") Set xlXML = CreateObject("MSXML2.DOMDocument") xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML) rst.Open xlXML Set GetRecordset = rst End Function 

Заметки:

  • вам не нужно назначать переменные объекта для разных столбцов, вместо этого вы можете использовать YourRecordsetObject!YourColumn или (внутри a) простой !YourColumn для извлечения значения.
  • вы можете фильтровать до цикла, что может быть альтернативой If ... Then ... Else и ускорить процесс

Надеюсь это поможет.

  • Создать назначение календаря
  • Скопируйте и вставьте данные на Mac с помощью терминала
  • VBA Excel запросит закрытую книгу без ее открытия
  • Фильтр VBA и копирование данных по условию
  • Изменение Excel VBA для MAC
  • Ошибка при закрытии открытой книги в пользовательской форме VBA
  • Загрузить файл с веб-сайта
  • Excel VBA :: Найти функцию в цикле
  • ошибка времени выполнения 1004 в excel 2010 Обновить BackgroundQuery
  • Ошибка ExecuteExcel4Macro - 1004 на Mac
  • Pathname работает на ПК, но не mac
  • Interesting Posts

    Вычисление Excel VBA TextToColumns НЕ разделение пробелами

    присваивание всего столбца данных конкретному столбцу массива в vba

    Макрос VBA работает на листе 1, но не на листе 2

    Защита рабочей таблицы Macro Enabled в книге

    Два десятичных запятых, изменяющихся на многие десятичные числа в ячейке

    Как я могу применить фильтры пользователя к выбору в excel vba?

    Копирование листа в последний ряд листа из другой книги

    Как скопировать конкретные столбцы с одного листа и вставить на другой лист в другом диапазоне?

    Кнопка экспорта файла без навигации по страницам в ASP.net MVC4

    Ошибка времени выполнения '1004': метод 'FormulaR1C1' объекта 'Range' не выполнен

    Установщик для пакета файлов Excel + VBA + exe + CSV-файлы

    VBA RegExp для специальных символов

    excel vba followhyperlink метод, когда книга не открыта

    PHPExcel занимает много времени, чтобы загрузить xls, отлично с xlsx

    Определенная пользователем или объектная ошибка в случае выбора

    Давайте будем гением компьютера.