Excel vba计数标题并将相同长度的活动行复制到新工作表

Question

我是vba的新手并且正在与宏观进行斗争。

我录制了一个宏，然后尝试调整它。

我所拥有的是当前标题为c1：t1的驱动程序列表，但是当我添加或删除驱动程序时，我需要在下面进行选择以适应。

B2是一个合并的单元格（B2：B5），其中包含日期，而且列中的列仍然是单个单元格。

对于一年中的每一天，日期以相同的格式一直重复。

我要做的是选择一个日期，然后按ctrl + q并将标题中的驱动程序名称列表复制到A列中的新工作表中，并选择日期和列数以匹配数字标题中的驱动程序。

Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+q
'

    Selection.Copy
    Sheets("Daily").Select
    Range("C4:F4").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False



    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Arial"
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

        Sheets("Weekly").Select
        Range("c1", Range("CV1").End(xlToLeft)).Select
        Selection.Copy
        Sheets("Daily").Select
        Range("A5").Select
        ActiveWindow.SmallScroll Down:=-27
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
    Application.CutCopyMode = False
    Sheets("Weekly").Select
    Application.CutCopyMode = False

        Sheets("Daily").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    Selection.ClearContents
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    Selection.ClearComments
    Sheets("Weekly").Select
    Application.CutCopyMode = False
End Sub

Answer 1

Dim lCol As Long, cpycel As Range
Set cpycel = Range(ActiveCell.Address)
lCol = (Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column) - 1
cpycel.Resize(4, lCol).Select

Selection.Copy
Sheets("Daily").Select
Range("C4:F4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Application.CutCopyMode = False

Sheets("Weekly").Select
Range(Cells(1, 2), Cells(1, (lCol + 1))).Select
Selection.Copy
Sheets("Daily").Select
Range("a4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Application.CutCopyMode = False

Range(Cells(5, 1), Cells((lCol + 3), 6)).Select