Question

我录制了一个宏，我想要获得的是创建一个代码，该代码将在每个工作表的代码中复制以下范围，然后将它们粘贴在彼此之下的行中并在＃34; Master＆＃34上;。

我有以下代码：

Sub Macro1()
'
' Macro1 Macro
'

'
 Dim rng As Range
Sheets("AL-Jackson Hospital-Fvar").Select

Set rng = Range( _
"K50:M50,K58:M58,K59:M59,K55:M55,K12:M12,K14:M14,K24:L24,K28:L28,K29:L29,K35:L35,K62:L62,K32:L32,K30:L30,K31:L31,K63:L63,K33:L33,K34:L34,K37:L37,K40:L40,K41:L41,K42:L42,K46:L46" _
    )
rng.Select
Selection.Copy
Sheets("Master").Select
Range("B4").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst

End Sub

例如：在工作表1,2,3上复制每个工作表上的以下范围，并粘贴为工作表主数据从单元格B1开始。因此，第1页数据范围应为B1，第2页数据范围应为b2，第3页数据范围应为b3等....

伙计我的工作簿有50多张

Answer 1

类似的东西应该适合你：

Sub tgr()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsDest As Worksheet
    Dim rCell As Range
    Dim aData() As Variant
    Dim sCells As String
    Dim i As Long, j As Long

    Set wb = ActiveWorkbook
    Set wsDest = wb.Sheets("Master")
    sCells = "K50:M50,K58:M58,K59:M59,K55:M55,K12:M12,K14:M14,K24:L24,K28:L28,K29:L29,K35:L35,K62:L62,K32:L32,K30:L30,K31:L31,K63:L63,K33:L33,K34:L34,K37:L37,K40:L40,K41:L41,K42:L42,K46:L46"

    ReDim aData(1 To wb.Sheets.Count - 1, 1 To wsDest.Range(sCells).Cells.Count)

    i = 0
    For Each ws In wb.Sheets
        If ws.Name <> wsDest.Name Then
            i = i + 1
            j = 0
            For Each rCell In ws.Range(sCells).Cells
                j = j + 1
                aData(i, j) = rCell.Value
            Next rCell
        End If
    Next ws

    wsDest.Range("B1").Resize(UBound(aData, 1), UBound(aData, 2)).Value = aData

End Sub

Answer 2

这是一个替代方案＆＃34;公式＆＃34;方法

除了采用另一种方法之外，它还减少了从（nsheets-1）* ncells（根据tigeravatar＆＃39; s解决方案）到（nsheets-1）+ ncells的迭代次数，如果它是一个相关问题

Option Explicit

Sub main()

    Dim ws As Worksheet
    Dim cell As Range, refCell As Range

    With ActiveWorkbook.Sheets("Master")
        For Each ws In wb.Sheets
             .Cells(.Rows.Count, 1).End(xlUp).Offset(1) = IIf(ws.Name <> .Name, ws.Name, "")
        Next ws
        Set refCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)

        For Each cell In Range("K50:M50,K58:M58,K59:M59,K55:M55,K12:M12,K14:M14,K24:L24,K28:L28,K29:L29,K35:L35,K62:L62,K32:L32,K30:L30,K31:L31,K63:L63,K33:L33,K34:L34,K37:L37,K40:L40,K41:L41,K42:L42,K46:L46")
            .Cells(refCell.Row, .Columns.Count).End(xlToLeft).Offset(, 1).Value = cell.Address ' set the reference for INDIRECT() function
        Next cell
        With .Range("B2", .Cells(refCell.Row, .Columns.Count).End(xlToLeft).Offset(-1))
            .FormulaR1C1 = "=INDIRECT(ADDRESS(ROW(INDIRECT(R" & refCell.Row & "C)),COLUMN(INDIRECT(R" & refCell.Row & "C)),,,RC1))"
            .Value = .Value
            .Offset(.Rows.Count).Resize(1).ClearContents
        End With
    End With

End Sub

它将工作表名称留在列＃34; A＆＃34;：它们可以删除

用于复制多个单元格范围并在另一个工作表上粘贴一行的宏

2 个答案: