Копирование из диапазона ячеек, определенных при исполнении, ячеек, соответствующих цвету интерьера (ExcelVBA) - PullRequest
Новая
       17

Копирование из диапазона ячеек, определенных при исполнении, ячеек, соответствующих цвету интерьера (ExcelVBA)

0 голосов
/ 08 ноября 2018

Моя проблема при использовании Excel VBA - попытаться проверить, есть ли ячейки определенного цвета на листе рабочей книги (workBB) перед применением фильтра по цвету (RGB (1, 255, 1)) на листе ( SheetNameFromArray), а затем скопируйте видимые ячейки в лист другой рабочей книги (workbookA) с тем же именем (SheetNameFromArray).

Решение, которое я пробовал, включало использование Application.CountIf (диапазон, условие) для подсчета ячеек, у которых был цвет RGB (1, 255, 1), а затем, если есть ячейки с цветом, переходите к фильтрации и копированию. , Но по какой-то причине кажется, что он не считает должным образом ячейки, потому что он никогда не копирует никакие ячейки, даже если на листе есть ячейки с таким цветом внутри диапазона (см. Пример ниже): 

    LastSheetRow = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row
    LastSheetColumn = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(1, Columns.Count).End(xlToLeft).Column

    WorkbookALastSheetRow = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row

    Dim rngWorkbookBToCopy As Range, rngWorkbookAToPaste As Range
    With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
        Set rngWorkbookBToCopy = .Range(.Cells(2, 1), .Cells(LastSheetRow, LastSheetColumn - 1))
    End With
    With Workbooks(WorkbookA).Sheets(RevisionSheetNameFromArray)
        Set rngWorkbookAToPaste = .Cells(WorkbookALastSheetRow, 1)
    End With

    If Application.CountIf(rngWorkbookBToCopy, RGB(1, 255, 1)) = 0 Then
    Else
        With Workbooks(WorkbookB).Worksheets(RevisionSheetNameFromArray)
            .Range(.Cells(1, 1), .Cells(LastSheetRow, LastSheetColumn)).AutoFilter Field:=1, Criteria1:=RGB(1, 255, 1), Operator:=xlFilterCellColor
        End With            
        rngWorkbookBToCopy.SpecialCells(xlCellTypeVisible).Copy rngWorkbookAToPaste           
    End If

То, что я хотел бы сделать, это скопировать только диапазон строк, у которых есть по крайней мере ячейка, окрашенная в RGB (96, 255, 210). Я добавил условие, чтобы проверить, есть ли ячейки указанного цвета, потому что, если на листе не было ячеек, появилась ошибка свойства Автофильтр диапазона. Но, как я уже сказал, похоже, клетки не учитываются должным образом, и я не уверен, как их решить.

Пожалуйста, помогите мне и спасибо заранее (и извините за мой плохой английский)

1 Ответ

0 голосов
/ 09 ноября 2018

Я нашел обходной путь, основанный на этой публикации в службе поддержки Microsoft.

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

Function CountCcolor(range_data As Range, criteria As Long) As Long
    Dim datax As Range
    Dim xcolor As Long
    xcolor = criteria
    For Each datax In range_data
        If datax.Interior.Color = xcolor Then
            CountCcolor = CountCcolor + 1
        End If
    Next datax
End Function

Применяя это изменение, код теперь будет выглядеть следующим образом: 

LastSheetRow = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row
LastSheetColumn = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(1, Columns.Count).End(xlToLeft).Column

WorkbookALastSheetRow = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row

Dim rngWorkbookBToCopy As Range, rngWorkbookAToPaste As Range
With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
    Set rngWorkbookBToCopy = .Range(.Cells(2, 1), .Cells(LastSheetRow, LastSheetColumn - 1))
End With
With Workbooks(WorkbookA).Sheets(RevisionSheetNameFromArray)
    Set rngWorkbookAToPaste = .Cells(WorkbookALastSheetRow, 1)
End With

If CountCcolor(rngWorkbookBToCopy, RGB(1, 255, 1)) = 0 Then
Else
    With Workbooks(WorkbookB).Worksheets(RevisionSheetNameFromArray)
        .Range(.Cells(1, 1), .Cells(LastSheetRow, LastSheetColumn)).AutoFilter Field:=1, Criteria1:=RGB(1, 255, 1), Operator:=xlFilterCellColor
    End With            
    rngWorkbookBToCopy.SpecialCells(xlCellTypeVisible).Copy rngWorkbookAToPaste           
End If

Надеюсь, это поможет другим людям, которые могут столкнуться с такой ситуацией.

...