将多个工作表中的值复制并粘贴到摘要工作表中

Posted 2023-03-27

【中文标题】将多个工作表中的值复制并粘贴到摘要工作表中

【英文标题】：Copy values from multiple sheets to summary sheet

【发布时间】：2022-01-21 07:50:55

【问题描述】：

如图所示，L、M、W:Z 列中有一些空单元格。 我正在尝试遍历工作簿中的所有工作表。从 Sheet1 开始，过滤掉“A7”中蓝色标题下的空“L”单元格，复制值数组（理想情况下，在 A:Z 或行中具有值的所有单元格之间），将复制的数组粘贴到摘要中工作表，为每个工作表复制 P2 并将值粘贴为工作表之间的分隔符。然后继续循环通过床单。 通常，这些工作簿有 100 到 150 张纸——这就是我试图自动化这个过程的原因。 给帮助者的注意事项：

非常感谢您抽出宝贵的时间，非常有礼貌！如果你住在落基山脉，让我给你买杯啤酒。 这些工作簿是为工作而生成的，因此我已相应地调整了值。 到处都是南方公园的参考资料是我使用 VBA 的风格，因为没有其他人看到或使用它们 我是 VBA 新手，为了达到我的最终目标，我从 Web 上的各种堆栈溢出中剪切和粘贴之前的项目。我在这方面遇到了很大的困难，我将非常感谢您的帮助！ 到目前为止的问题：行号是动态的，在没有变化的情况下过滤后，我似乎无法使用“A7”行的偏移量。

Sub Missing_L_Value_Summary()
Dim MyRange As Range
Dim MyCell As Range
Dim ws As Worksheet, myValue
Dim lCount As Long
Dim title As Long
Dim rng As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
    ActiveSheet.Name = "Sheet1"
    'Workbook.Save.Name = Range("A2") & "James Cameron"
    'Range("A2").Copy
    Sheets.Add.Name = "Summary"
    Sheets("Summary").Select
    'Range("A1").PasteSpecial
    ActiveCell.Offset(2, 1).Select
    Sheets("Sheet1").Select
    Range("A8").Copy
    Sheets("Summary").Select
    ActiveCell.PasteSpecial
    Range("B3").EntireColumn.AutoFit
    Sheets("Sheet1").Select
    Range("$A$7:$Z$7").Copy
    Sheets("Summary").Select
    ActiveCell.Offset(1, 0).PasteSpecial
    Sheets("Sheet1").Select
    For Each ws In Sheets
            Range("L7").Select
            With ws.Cells(7, 12).CurrentRegion
                .AutoFilter Field:=12, Criteria1:="="'
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox("James Cameron doesn't do what James Cameron does for James Cameron. James Cameron does 
End Sub
what James Cameron does for James Cameron!")

【问题讨论】：

没有发布图片。将示例数据显示为文本表。

我知道，June7。我找不到资源上传区域。我是新来的，在工作了 15 小时后，我在深夜发布了这篇文章。如果您对在哪里张贴表格有任何建议，我很乐意进行编辑！

欢迎您！如果您要编辑帖子以阐明您要做什么以及问题出在哪里，那么它将帮助其他人帮助您解决问题。另外，请查看“How to Ask”以及如何创建minimal reproducible example。

【参考方案1】：

获取过滤的行

Option Explicit

Sub Missing_L_Value_Summary()
    Const ProcName As String = "Missing_L_Value_Summary"
    On Error GoTo ClearError
    Dim IsSuccess As Boolean
    
    Const sExceptionsList As String = "Summary" ' add more
    Const sExceptionsDelimiter As String = ","
    Const sBeforeSheetName As String = "Sheet1"
    Const sfCellAddressCR As String = "L7"
    Const sDateAddress As String = "P2"
    Const sField As Long = 12
    Const sCriteria As String = "="
    
    Const dName As String = "Summary"
    Const dfCellAddress As String = "A3"
    Const dDateCol As String = "B"
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
        
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
        
    Dim dws As Worksheet
    On Error Resume Next ' prevent error if it doesn't exist
        Set dws = wb.Worksheets(dName)
    On Error GoTo ClearError
    If Not dws Is Nothing Then
        Application.DisplayAlerts = False ' delete without confirmation
        dws.Delete
        Application.DisplayAlerts = True
    End If
    Set dws = wb.Worksheets.Add(Before:=wb.Worksheets(sBeforeSheetName))
    dws.Name = dName
    
    Dim dCell As Range: Set dCell = dws.Range(dfCellAddress)
    
    Dim sExceptions() As String
    sExceptions = Split(sExceptionsList, sExceptionsDelimiter)
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim svrg As Range
    Dim drg As Range
    Dim dData As Variant
    Dim drCount As Long
    Dim ErrNum As Long
    
    For Each sws In wb.Worksheets
        If IsError(Application.Match(sws.Name, sExceptions, 0)) Then
            If sws.AutoFilterMode Then sws.AutoFilterMode = False
            ' Write date.
            dCell.EntireRow.Columns(dDateCol).Value = sws.Range(sDateAddress)
            Set dCell = dCell.Offset(1)
            ' Write data.
            Set srg = sws.Range(sfCellAddressCR).CurrentRegion
            On Error Resume Next
                srg.AutoFilter sField, sCriteria
                ErrNum = Err.Number
            On Error GoTo ClearError
            If ErrNum = 0 Then
                On Error Resume Next
                    Set svrg = srg.SpecialCells(xlCellTypeVisible)
                On Error GoTo ClearError
                sws.AutoFilterMode = False
                If Not svrg Is Nothing Then
                    dData = GetFilteredRows(svrg)
                    If Not IsEmpty(dData) Then
                        drCount = UBound(dData, 1)
                        Set drg = dCell.Resize(drCount, UBound(dData, 2))
                        drg.Value = dData
                        Set dCell = dCell.Offset(drCount)
                        Set svrg = Nothing
                    End If
                End If
            End If
        End If
    Next sws
    
    IsSuccess = True
    
SafeExit:
    
    If Application.EnableEvents = False Then
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
    
    If IsSuccess Then
        MsgBox "James Cameron doesn't do what James Cameron does " _
            & "for James Cameron. James Cameron does what James Cameron does " _
            & "for James Cameron!", vbInformation
    Else
        MsgBox "Something went wrong.", vbCritical
    End If

    Exit Sub

ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume SafeExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a filtered range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredRows( _
    ByVal FilteredRange As Range) _
As Variant
    Const ProcName As String = "GetFilteredRows"
    On Error GoTo ClearError

    Dim saCount, drCount, cCount
    
    With FilteredRange
        saCount = .Areas.Count
        drCount = Intersect(.Offset(0), _
            .Worksheet.Columns(.Cells(1).Column)).Cells.Count
        cCount = .Areas(1).Columns.Count
    End With
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
    
    Dim sarg As Range
    Dim sData As Variant
    Dim srCount As Long, sr As Long, dr As Long, c As Long
    
    For Each sarg In FilteredRange.Areas
        srCount = sarg.Rows.Count
        If cCount + srCount > 2 Then
            sData = sarg.Value
        Else
            ReDim sData(1 To 1, 1 To 1)
            sData(1, 1) = sarg.Value
        End If
        For sr = 1 To srCount
            dr = dr + 1
            For c = 1 To cCount
                dData(dr, c) = sData(sr, c)
            Next c
        Next sr
    Next sarg
    
    GetFilteredRows = dData

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

【讨论】：

先生...您是个传奇人物。非常感谢您的帮助！！

【参考方案2】：

我只使用偏移公式，因为如果我删除行或列，他永远不会出错 例如：如果我在 sheet2 的单元格 B5 中并希望显示来自 sheet1 的相同信息

=OFFSET(sheet1!$A$1;ROW(B5)-1;COLUMN(B5)-1)

只有单元格修复是 A1 sheet1