Не могу сообразить как сделать формулу. Надо из массива данных по одной из колонок рассортировать данные по разным таблицам, исходя из содержимого в одной колонке. При этом в зависимости от изменения в основной таблице чтобы данные динамически менялись в отсортированных листах.
Как примерно хочу это видеть - в примере.
Не могу сообразить как сделать формулу. Надо из массива данных по одной из колонок рассортировать данные по разным таблицам, исходя из содержимого в одной колонке. При этом в зависимости от изменения в основной таблице чтобы данные динамически менялись в отсортированных листах.
Дополнительный вопрос. Можно ли переносить и "условное форматирование" переносимых на другие листы ячеек из исходной таблицы? Или лучше в каждой таблице прописать правила и форматировать содержимое?
Дополнительный вопрос. Можно ли переносить и "условное форматирование" переносимых на другие листы ячеек из исходной таблицы? Или лучше в каждой таблице прописать правила и форматировать содержимое?sercam
Сообщение отредактировал sercam - Пятница, 18.02.2022, 10:07
Private Sub Workbook_SheetActivate(ByVal Sh As Object) Application.ScreenUpdating = False a = ActiveSheet.Name If a <> "Исходная таблица" Then b = Range("g1").Value c = Cells(Rows.Count, "c").End(xlUp).Row If c > 5 Then Range("c6:g" & c).Clear d = Sheets("Исходная таблица").Cells(Rows.Count, "b").End(xlUp).Row If d > 4 Then For Each e In Sheets("Исходная таблица").Range("f5:f" & d) If e = b Then f = Cells(Rows.Count, "c").End(xlUp).Row + 1 g = e.Row Sheets("Исходная таблица").Range("b" & g & ":f" & g).Copy Range("c" & f) End If Next End If End If Application.ScreenUpdating = True End Sub
[/vba]
в модуль книги [vba]
Код
Private Sub Workbook_SheetActivate(ByVal Sh As Object) Application.ScreenUpdating = False a = ActiveSheet.Name If a <> "Исходная таблица" Then b = Range("g1").Value c = Cells(Rows.Count, "c").End(xlUp).Row If c > 5 Then Range("c6:g" & c).Clear d = Sheets("Исходная таблица").Cells(Rows.Count, "b").End(xlUp).Row If d > 4 Then For Each e In Sheets("Исходная таблица").Range("f5:f" & d) If e = b Then f = Cells(Rows.Count, "c").End(xlUp).Row + 1 g = e.Row Sheets("Исходная таблица").Range("b" & g & ":f" & g).Copy Range("c" & f) End If Next End If End If Application.ScreenUpdating = True End Sub
На примере - работает, на реальном файле у меня - нет. Возможно из-за объединённых ячеек некоторых на листе.
Как понять, разобрать этот макрос, чтобы исправить? Может выбрать не весь лист как исходный, а только диапазон таблицы, где нет объединённых ячеек?sercam
Private Sub Workbook_SheetActivate(ByVal Sh As Object) Application.ScreenUpdating = False a = ActiveSheet.Name If a <> "Общая" Then b = Range("c3").Value c = Cells(Rows.Count, "b").End(xlUp).Row If c > 8 Then Range("a9:h" & c).Clear d = Sheets("Общая").Cells(Rows.Count, "b").End(xlUp).Row If d > 7 Then For Each e In Sheets("Общая").Range("g8:g" & d) If e = b Then f = Cells(Rows.Count, "b").End(xlUp).Row + 1 If f = 8 Then f = 9 g = e.Row Sheets("Общая").Range("a" & g & ":h" & g).Copy Range("a" & f) Range("a" & f) = f - 8 End If Next End If End If Application.ScreenUpdating = True End Sub
[/vba]
[vba]
Код
Private Sub Workbook_SheetActivate(ByVal Sh As Object) Application.ScreenUpdating = False a = ActiveSheet.Name If a <> "Общая" Then b = Range("c3").Value c = Cells(Rows.Count, "b").End(xlUp).Row If c > 8 Then Range("a9:h" & c).Clear d = Sheets("Общая").Cells(Rows.Count, "b").End(xlUp).Row If d > 7 Then For Each e In Sheets("Общая").Range("g8:g" & d) If e = b Then f = Cells(Rows.Count, "b").End(xlUp).Row + 1 If f = 8 Then f = 9 g = e.Row Sheets("Общая").Range("a" & g & ":h" & g).Copy Range("a" & f) Range("a" & f) = f - 8 End If Next End If End If Application.ScreenUpdating = True End Sub
sercam, вы лист "Общая" случайно не переименовали? макрос рассчитан на имя этого листа. можете в макросе все Sheets("Общая") заменить на Sheets(1) если он будет всегда первым.
index забыл для (1) [vba]
Код
Private Sub Workbook_SheetActivate(ByVal Sh As Object) Application.ScreenUpdating = False a = ActiveSheet.Index If a <> 1 Then b = Range("c3").Value c = Cells(Rows.Count, "b").End(xlUp).Row If c > 8 Then Range("a9:h" & c).Clear d = Sheets(1).Cells(Rows.Count, "b").End(xlUp).Row If d > 7 Then For Each e In Sheets(1).Range("g8:g" & d) If e = b Then f = Cells(Rows.Count, "b").End(xlUp).Row + 1 If f = 8 Then f = 9 g = e.Row Sheets(1).Range("a" & g & ":h" & g).Copy Range("a" & f) Range("a" & f) = f - 8 End If Next End If End If Application.ScreenUpdating = True End Sub
[/vba]
sercam, вы лист "Общая" случайно не переименовали? макрос рассчитан на имя этого листа. можете в макросе все Sheets("Общая") заменить на Sheets(1) если он будет всегда первым.
index забыл для (1) [vba]
Код
Private Sub Workbook_SheetActivate(ByVal Sh As Object) Application.ScreenUpdating = False a = ActiveSheet.Index If a <> 1 Then b = Range("c3").Value c = Cells(Rows.Count, "b").End(xlUp).Row If c > 8 Then Range("a9:h" & c).Clear d = Sheets(1).Cells(Rows.Count, "b").End(xlUp).Row If d > 7 Then For Each e In Sheets(1).Range("g8:g" & d) If e = b Then f = Cells(Rows.Count, "b").End(xlUp).Row + 1 If f = 8 Then f = 9 g = e.Row Sheets(1).Range("a" & g & ":h" & g).Copy Range("a" & f) Range("a" & f) = f - 8 End If Next End If End If Application.ScreenUpdating = True End Sub