VBA Excel: Скопировать данные ячейки со смещением диапазона

[lapin9126]

Здравствуйте. Помогите с макросом, с помощью которого создаётся лист с текущей датой ("dd.mm.yyyy ") после активного листа, и копируются данные из активного листа из столбца "С" при условии, если в столбце "В" есть информация.

Пример: в ячейке "В11" активного листа есть информация, то скопировать данные из ячейки "С12" на созданный лист (dd.mm.yyyy). Но если в столбце "B" идут подряд заполненные две ячейки то копировать только данные одной первой ячейки. Пример: в ячейке "В11" и "B12"активного листа есть информация, то скопировать данные из ячейки "С12".

Кое что я уже пробовал, но копирует целыми строками.

Спойлер

Sub Copy_B_v_C()
    Dim c As Range: x = 2: On Error Resume Next
' создаём лист с текущей датой
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = Format(Now, "dd.mm.yyyy")
'переход на рабочий лист
    If ActiveSheet.Index <> ThisWorkbook.Sheets.Count Then
    Sheets(ActiveSheet.Index - 1).Select
    End If
'копирует данные на лист с датой, но целыми строками
    Set c = Columns(x).SpecialCells(2)
    If Not c Is Nothing Then
        Set c = Application.Union(c, Columns(x).SpecialCells(-4123))
    Else
        Set c = Columns(x).SpecialCells(-4123)
    End If
    c.EntireRow.Copy Destination:=Sheets(ActiveSheet.Index + 1).[a1]
End Sub

[свернуть]

[Администратор]

Почему смотрится ячейка B11, а копируется из C12, а не из C11?

[lapin9126]

Особенность заполнения документа (автоматически). А данные для дальнейшего использования нужны именно со смещением диапазона.

[Администратор]

Макрос

Sub Copy_B_v_C()
   
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim col As Range, ar As Range, lr As Long, c As Long
   
   
    '1. Отключение монитора (для ускорения макроса и чтобы не мерцало).
    Application.ScreenUpdating = False
   
    '2. Номер столбца на листе-источнике.
    c = 2
   
    '3. Присваиваем имя "shSrc" активному листу. Затем через это имя можно обращаться к активному листу
        ' (этот лист дальше не будет активным).
    Set shSrc = ActiveSheet
   
    '4. Создаём лист с текущей датой и присваиваем листу имя "shRes".
    Sheets.Add After:=ActiveSheet
    Set shRes = ActiveSheet
    On Error Resume Next
    shRes.name = Format(Now, "dd.mm.yyyy")
    On Error GoTo 0
   
    '5. Присваиваем имя "col" непустым ячейкам.
    On Error Resume Next
    Set col = shSrc.Columns(c).SpecialCells(xlCellTypeConstants)
    If Not col Is Nothing Then
        Set col = Application.Union(col, shSrc.Columns(c).SpecialCells(xlCellTypeFormulas))
    Else
        Set col = shSrc.Columns(c).SpecialCells(xlCellTypeFormulas)
    End If
    On Error GoTo 0
    If col Is Nothing Then
        Application.DisplayAlerts = False
        shRes.Delete
        Application.DisplayAlerts = True
        shSrc.Select
        Application.ScreenUpdating = True
        MsgBox "Столбец " & c & " пустой.", vbExclamation
        Exit Sub
    End If
   
    '6. Копирование данных из листа-источника на лист-результат.
    For Each ar In col.Areas
        lr = shRes.UsedRange.Row + 1
        ar.Rows(2).EntireRow.Copy Destination:=shRes.Rows(lr)
    Next ar
    shRes.Rows(1).Delete
   
    '7. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub

[свернуть]

[lapin9126]

Макрос копирует первое и последнее значение (копирует полностью строку, ну это можно удалить руками) и пропускает все остальные. Должно получаться - прикрепил файл с примером. Еще прошу прощения забыл уточнить диапазон начинается с 3 строки (первые две техническая информация).

[вложение удалено администратором]

[Администратор]

Копируются только данные, без оформления.

Макрос

Sub Copy_B_v_C()
   
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim col As Range, ar As Range, lr As Long, c As Long
   
   
    '1. Отключение монитора (для ускорения макроса и чтобы не мерцало).
    Application.ScreenUpdating = False
   
    '2. Номер столбца на листе-источнике.
    c = 2
   
    '3. Присваиваем имя "shSrc" активному листу. Затем через это имя можно обращаться к активному листу
        ' (этот лист дальше не будет активным).
    Set shSrc = ActiveSheet
   
    '4. Создаём лист с текущей датой и присваиваем листу имя "shRes".
    Sheets.Add After:=ActiveSheet
    Set shRes = ActiveSheet
    On Error Resume Next
    shRes.name = Format(Now, "dd.mm.yyyy")
    On Error GoTo 0
   
    '5. Присваиваем имя "col" непустым ячейкам в столбце c (c - имя переменной).
    On Error Resume Next
    Set col = shSrc.Columns(c).SpecialCells(xlCellTypeConstants)
    If Not col Is Nothing Then
        Set col = Application.Union(col, shSrc.Columns(c).SpecialCells(xlCellTypeFormulas))
    Else
        Set col = shSrc.Columns(c).SpecialCells(xlCellTypeFormulas)
    End If
    On Error GoTo 0
    If col Is Nothing Then
        Application.DisplayAlerts = False
        shRes.Delete
        Application.DisplayAlerts = True
        shSrc.Select
        Application.ScreenUpdating = True
        MsgBox "Столбец " & c & " пустой.", vbExclamation
        Exit Sub
    End If
   
    '6. Копирование данных из листа-источника на лист-результат.
    For Each ar In col.Areas
        lr = shRes.UsedRange.Row + shRes.UsedRange.Rows.Count
        shRes.Cells(lr, "b").Value = ar.Cells(1, 1).Value
        shRes.Cells(lr, "c").Value = ar.Cells(2, 2).Value
    Next ar
    shRes.Rows(1).Delete
   
    '7. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub

[свернуть]

[lapin9126]

Спасибо огромное, то что нужно.