Копирование ячеек, по заполняемости ячеек. На разные листы.

Пользователь

Сообщений: 1 Регистрация: 07.12.2019

07.12.2019 21:27:30

Копирование ячеек, из шапки таблицы (ФИО, наименование, вид ТО), по условию (заполнена ячейка "вид ТО" за определенный месяц), в таблицу на странице месяца
Если в ячейке вид ТО за месяц пусто, то не копируются ячейки.

Пример: заливкой выделил за два месяца январь и февраль.

Нашел решение, где копируются строки с цифрой "1". Не знаю как копировать вид ТО за определенный месяц.

Код

Sub toCSV()
Dim x
Dim i&, v&, c&
Dim arRes(1 To 10000, 1 To 2)
v = 0
x = Sheets(1).Range("A2:S" & Sheets(1).[a65536].End(xlUp).Row).Value
For i = 1 To UBound(x)
    If x(i, 1) = "1" Then
    v = v + 1
        For c = 1 To 2
            arRes(v, c) = x(i, c + 14)
        Next
    End If
Next
Sheets(2).[B3].Resize(v, 2) = arRes
Sheets(2).Columns("B:E").AutoFit
End Sub

Заранее спасибо.

Прикрепленные файлы

grafik.xlsx (19.17 КБ)

ocet p

Пользователь

Сообщений: 448 Регистрация: 24.03.2018

08.12.2019 04:35:35

Например:
(имена листов должны совпадать с названиями месяцев в заголовках таблицы)

Код

Option Explicit

Sub abc_xyz()
    Dim c%, cl%, r&, rw&, nr&
    Dim sh As Worksheet
    
    With ThisWorkbook
        Set sh = .Sheets("ГОД")
        rw = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
        cl = 15
        
        For c = 4 To cl
            With .Sheets(sh.Cells(7, c).Value) ' названия месяцев <=> заголовки таблицы
                '.Select
                nr = 6
                For r = 8 To rw
                    If Trim(sh.Cells(r, c).Value) <> "" Then
                        .Range("A" & nr & ":D" & nr).Value = Array(nr - 5, sh.Cells(r, "B").Value, sh.Cells(r, "C").Value, sh.Cells(r, c).Value)
                        nr = nr + 1
                    End If
                Next
            End With
        Next
        
        Set sh = Nothing
    End With
    
    MsgBox "Сделано"
End Sub