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

我是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

---

数据的屏幕截图+您尝试的代码肯定会有帮助…：）将图片上传到某处，并将url放入问题中。通常，一个善良的（较高声誉的）用户会改变问题来显示你的形象

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