Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Выборка в эксель
 
#1
12.03.2026 12:56:00
Добрый день!
Имеется таблица Эксель (табель), где разными цветами с помощью заливки выделены часы у сотрудников.
У меня прописан макрос для подсчета кол-ва часов согласно цвета заливки.
Есть ли возможность по определенному цвету заливки в таблице формировать отчет (новый лист), где будет произведена выборка фио данного сотрудника день согласно таблицы и кол-во часов?
 
 
 
#2
12.03.2026 13:09:00
У Вас в файле уже всё необходимое есть. Вставьте формулу:
Код
=SumByColor(C4:AG4;K4)
Вместо K4 можно вставить какую-то другую эталонную ячейку.
 
 
 
#3
12.03.2026 13:14:21
Мне нужно, чтобы из таблицы, где более например 100 человек были выделены и перенесены на новый лист только те сотрудники которые работали по определенному цвету заливки т.е. их ФИО даты сверху как в таблице и кол-во часов. Для примера выделила вкладку красным цветом то, что хочу видеть не знаю возможно ли это? Сейчас делаю все вручную
 
 
 
#4
12.03.2026 13:15:05
1. Название лучше предложить посодержательней, вариант названия темы:
Суммирование ячеек по цвету.

2. 19-го числа цвет ячейки отличается от 18-го и 20-го числа.
 
 
 
#5
12.03.2026 13:38:35
Таблица имеет до 50 цветов заливки в месяц. Для примера оставила 1 графу таблицы, где это видно. Для упрощения выборки был прописан макрос для суммирования согласно цвета заливки, но для работы также требуется разнести всех людей по мелким табелям согласно цвета заливки.
 
 
 
#6
12.03.2026 13:40:12
В качестве эталона цвета используется цвет активной ячейки.
Код
Option Explicit

Sub Move_lines()
    Move_lines_job ActiveSheet
End Sub
Private Sub Move_lines_job(shSource As Worksheet)
    CloseEmptyWb
    shSource.Copy
    
    Dim FIO As Range
    Set FIO = ActiveSheet.UsedRange.Find("Ф.И.О.").Cells(1, 1)
    
    Dim yu As Long, xu As Long, keepRow As Boolean
    Dim curColor As Long
    curColor = ActiveCell.Interior.Color
    
    For yu = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To FIO.Row + 2 Step -1
        keepRow = False
        For xu = ActiveSheet.UsedRange.Column To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
            If ActiveSheet.Cells(yu, xu).Interior.Color = curColor Then
                keepRow = True
                Exit For
            End If
        Next
        If keepRow Then
            For xu = FIO.Column To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
                Select Case ActiveSheet.Cells(yu, xu).Interior.Color
                Case RGB(255, 255, 255), curColor
                Case Else
                    With ActiveSheet.Cells(yu, xu)
                        .ClearContents
                        .Interior.Pattern = xlNone
                    End With
                End Select
            Next
        Else
            ActiveSheet.Rows(yu).EntireRow.Delete
        End If
    Next
    
    ActiveWorkbook.Saved = True
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub
 
 
 
#7
12.03.2026 14:01:34
Этот макрос разносит разные цвета на разные листы.
Код
Option Explicit

Sub Move_colors()
    Move_lines_job ActiveSheet
End Sub

Private Sub Move_lines_job(shSource As Worksheet)
    CloseEmptyWb
    shSource.Copy
    
    Dim FIO As Range
    Set FIO = ActiveSheet.UsedRange.Find("Ф.И.О.").Cells(1, 1)
    
    Dim dic As Object
    Set dic = GetDicColor(FIO)
    
    Dim vColor As Variant
    For Each vColor In dic.Keys()
        Move_one CStr(vColor), dic(vColor), FIO
    Next
End Sub

Private Sub Move_one(sheetName As String, sampleAddress As String, FIO As Range)
    FIO.Parent.Copy After:=FIO.Parent
    ActiveSheet.Name = sheetName
    
    Dim yu As Long, xu As Long, keepRow As Boolean
    Dim curColor As Long
    curColor = Range(sampleAddress).Interior.Color
    
    For yu = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To FIO.Row + 2 Step -1
        keepRow = False
        For xu = ActiveSheet.UsedRange.Column To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
            If ActiveSheet.Cells(yu, xu).Interior.Color = curColor Then
                keepRow = True
                Exit For
            End If
        Next
        If keepRow Then
            For xu = FIO.Column To ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
                Select Case ActiveSheet.Cells(yu, xu).Interior.Color
                Case RGB(255, 255, 255), curColor
                Case Else
                    With ActiveSheet.Cells(yu, xu)
                        .ClearContents
                        .Interior.Pattern = xlNone
                    End With
                End Select
            Next
        Else
            ActiveSheet.Rows(yu).EntireRow.Delete
        End If
    Next
    
    ActiveWorkbook.Saved = True
End Sub

Private Function GetDicColor(FIO As Range) As Object
    Dim sh As Worksheet
    Set sh = FIO.Parent
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim yu As Long, xu As Long
    For yu = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1 To FIO.Row + 2 Step -1
        For xu = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1 To FIO.Column + 1 Step -1
            If sh.Cells(yu, xu).Interior.Color <> RGB(255, 255, 255) Then
                dic(sh.Cells(yu, xu).Interior.Color) = sh.Cells(yu, xu).Address(0, 0, xlA1)
            End If
        Next
    Next
    Set GetDicColor = dic
End Function

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub
 
 
 
Страницы: 1
Читают тему
Наверх