Форум по VBA и MS Office

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

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

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