Question

**'Dim raport As Worksheet
'Dim daty As String
'Dim lcolumn As Long
'Dim mycolaaa As String
'Dim dataT As Variant
'Set raport = ActiveWorkbook.Sheets("sheet1")
'raport.Activate
'lcolumn = raport.Cells(1, Columns.Count).End(xlToLeft).Column

'daty = ("A1:xy1")

'With raport
'raport.Range(daty).Select
'End With
'Selection.Copy
'dataT = Application.Transpose(Data)
'With tarws
'CopyRangeAddress = .Range("A2:A100").Address
   ' .Range(CopyRangeAddress).PasteSpecial xlPasteValues
    '.Range(CopyRangeAddress).PasteSpecial xlPasteFormats
    '.Range(CopyRangeAddress).PasteSpecial xlPasteColumnWidths
'End With

srcws.Activate       

'With srcws
    '.Range(sortrangeaddress).Select
'End With
'Selection.Copy
'Paste the Sort Range on to the target worksheet
'The CopyRangeAddress will be A1 through the last Row
'and column 2 -- so something like A1:B2
'With tarws
    'CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol), _
            '.Cells(pasteRow + lrow - 2, 2)).Address
    '.Range(CopyRangeAddress).PasteSpecial xlPasteValues
    '.Range(CopyRangeAddress).PasteSpecial xlPasteFormats
    '.Range(CopyRangeAddress).PasteSpecial xlPasteColumnWidths
'End With**

如何添加“有效”单元格而不是sortrangeadress？它是源工作表中的数据，作为您帮助我进行转置的下面单元格的标题，位于一行中。非常感谢您之前的回答！

Answer 1

从您的图片看来，您正在尝试取消透视表的作用。解决此问题的最佳方法是为每个“日期”分组创建较小的范围。下面的代码提供了如何在分组之间移动的示例。

Option Explicit


Public Sub Example()
    Const firstDataCell As Long = 3 'Column C
    Const columnsInDataGroup As Long = 10
    Const DataRowStart As Long = 2 'Row 2

    'Worksheet with the source data
    Dim srcWs As Worksheet
    Set srcWs = ActiveWorkbook.Sheets("Sheet1")
    'Worksheet to write data to
    Dim tarWs As Worksheet
    Set tarWs = ActiveWorkbook.Sheets("Sheet2")

    'Get the last row of data
    Dim lRow As Long
    lRow = LastRow(srcWs)

    'Get the last column containing data
    Dim lCol As Long
    lCol = LastColumn(srcWs)

    'This are the first columns you seem to
    'want to sort the data on
    Dim SortRangeAddress As String
    SortRangeAddress = "A2:B" & Trim(CStr(lRow))

    'This variable will contain the address of
    'each Date Data Group as your macro
    'loops across the columns
    Dim dateDataGroupRangeAddress As String

    Dim row As Long
    Dim col As Long
    Dim pasteRow As Long: pasteRow = 1
    Dim pasteCol As Long: pasteCol = 1
    Dim CopyRangeAddress As String

    For col = firstDataCell To lCol Step columnsInDataGroup
        'Copy the Sort Range from the source worksheet to
        'the target worksheet.
        With srcWs
            .Range(SortRangeAddress).Select
        End With
        Selection.Copy

        'Paste the Sort Range on to the target worksheet
        'The CopyRangeAddress will be A1 through the last Row
        'and column 2 -- so something like A1:B2
        With tarWs
            CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol), _
                    .Cells(pasteRow + lRow - 2, 2)).Address
            .Range(CopyRangeAddress).PasteSpecial xlPasteValues
        End With

        'Copy the next source date data group. The width of the selection
        'is determine by columnsInDataGroup constant set above less 1
        'Think of the first .Cells as 1 and the second .Cells as
        'columnsInDataGroup - 1.
        With srcWs
            dateDataGroupRangeAddress = .Range(.Cells(DataRowStart, col), _
                    .Cells(lRow, col + columnsInDataGroup - 1)).Address
            .Range(dateDataGroupRangeAddress).Select
        End With
        Selection.Copy

        'Paste the next source date date group to the target worksheet
        'CopyRangeAddress here will move 2 columns over from the
        'Start of the sort data range (Columns A & B) to start the
        'paste in column C
        With tarWs
            CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol + 2), _
                    .Cells(pasteRow + lRow - 2, columnsInDataGroup + 2)).Address
            .Range(CopyRangeAddress).PasteSpecial xlPasteValues
        End With
        pasteRow = pasteRow + lRow - 1

    Next col

End Sub

Function LastRow(ByRef sh As Worksheet)

    LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlValues, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).row

End Function

Function LastColumn(ByRef sh As Worksheet)

    LastColumn = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlValues, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column

End Function

将10列中的一行更改为x行

1 个答案: