Ячейка заливки цветом VBA в диапазоне только в том случае, если ячейки в другом столбце не пустые

Надеюсь, вы сможете помочь. У меня есть фрагмент кода ниже. Он вызван в большую часть, которую я добавил далее ниже.

Что я Public Sub BorderForNonEmpty()хочу сделать, так это заполнить пустые ячейки в диапазоне A:C только цветом, если ячейки в столбце K не пустые. На данный момент у меня есть диапазон, установленный на Set myRange = ActiveSheet.Range("A2:C252")это, только чтобы увидеть, будет ли работать код. Он работает, но он, очевидно, заполняет желтый цвет для всех ячеек, которые пусты для A2:C252

Я хочу, чтобы мой код смотрел на столбец 11, если в столбце 11 нет пустых ячеек, а есть пустые ячейки в A:C, то да цвет. Но если в столбце 11 есть пустые ячейки, просто перестаньте искать пробелы для цвета в A: C и продолжите с остальной частью кода.

То, что я хочу сделать, это желтый цвет пустых ячеек в A, B и C для каждой страны

Как всегда любая помощь очень ценится.

Я добавил некоторые фотографии ниже.

Оригинал pic Введите описание изображения здесь

Бельгия после макро

Введите описание изображения здесь

Цвет пустых ячеек желтый код

Public Sub BorderForNonEmpty()
    Dim myRange As Range
    Set myRange = ActiveSheet.Range("A2:C252")

    'clear all color
    myRange.Interior.ColorIndex = xlNone

    'color only blank cells
    myRange.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 6
End Sub

Полный код, который открывает диалоговое окно и разбивает основную книгу на отдельные книги, отфильтрованные по странам в столбце 11

ПОЛНЫЙ КОД

Sub Open_Workbook_Dialog()

Dim my_FileName As Variant
Dim my_Workbook As Workbook

  MsgBox "Pick your CRO file" '<--| txt box for prompt to pick a file

  my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

  If my_FileName <> False Then
    Set my_Workbook = Workbooks.Open(Filename:=my_FileName)



    Call Filter(my_Workbook) '<--|Calls the Filter Code and executes

  End If
End Sub

Public Sub Filter(my_Workbook As Workbook)
  Dim rCountry As Range, helpCol As Range
  Dim wb As Workbook
  With my_Workbook.Sheets(1) '<--| refer to data worksheet
    With .UsedRange
      Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
    End With

   With .Range("A1:Y" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Y" from row 1 to last non empty row of column "A"
            .Columns(11).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 11th column of the referenced range and store its unique values in "helper" column
            Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
            For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
                .AutoFilter 11, rCountry.Value2 '<--| filter data on country field (11th column) with current unique country name
                If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
                    Set wb = Application.Workbooks.Add '<--... add new Workbook
                        wb.SaveAs Filename:=rCountry.Value2 '<--... saves the workbook after the country
                            .SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1")
                               ActiveSheet.Name = rCountry.Value2  '<--... rename it
                           .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
                           Sheets(1).Range("A1:Y1").WrapText = False 'Takes the wrap text off
                           ActiveWindow.Zoom = 55
                         Sheets(1).UsedRange.Columns.AutoFit 'Autofits the column
                         Call BorderForNonEmpty
                    wb.Close SaveChanges:=True '<--... saves and closes workbook
                End If
            Next
        End With
        .AutoFilterMode = False '<--| remove autofilter and show all rows back
    End With
    helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included)
End Sub

Public Sub BorderForNonEmpty()
    Dim myRange As Range
    Set myRange = ActiveSheet.Range("A2:C252")

    'clear all color
    myRange.Interior.ColorIndex = xlNone

    'color only blank cells
    myRange.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 6
End Sub

1 ответ

  1. Обновлено * * *
    Попробовать это. Он будет фильтровать по столбцу K для не-заготовок, а затем добавить желтый цвет к пустым ячейкам в столбце A:C.

    Public Sub Filter
    Dim wks As Worksheet
    
    Set wks = ThisWorkbook.Sheets("Sheet1")
    
       With wks
         .AutoFilterMode = False
         .Range("A:K").AutoFilter Field:=11, Criteria1:="<>", Operator:=xlFilterValues
         .Range("A:C").SpecialCells(xlCellTypeBlanks).Interior.Color = 65535
         .AutoFilterMode = False
       End With 
     End Sub