时间戳

首页 > 解决方案 > 合并包含公式/单元格引用的多个工作表中的数据

excel - 合并包含公式/单元格引用的多个工作表中的数据

问题描述

表 1 截图

范围截图

大家好！我之前发布过同样的问题，但这一次更用文件的截图来解释。

我有 85 张纸（第 1 张截图供参考）和每张纸的指定范围（I12：N42）。但是这个范围包括公式和单元格引用。我想做的是：

  1. 复制具有此范围 (I12:N42) 的所有 85 张工作表中的数据，除非“数量 = 0”。
  2. 仅将 PasteValues 复制的数据粘贴到主表。

PS：我尝试使用 Power Query 做同样的事情，但它很慢，所以 VBA 代码可能会在这方面工作得更快。

欣赏你们！

标签： excelvba

解决方案

请尝试下一个代码。它假定除了主表和提到的 85 之外没有其他表可以复制。如果是其他人，除了他们添加跳过主条件的新条件：

Sub copyNonZeroRowsInMaster()
    Dim sh As Worksheet, shM As Worksheet, rng As Range, lastRow As Long, boolOK As Boolean
    Dim arrRows, arrCopy, arr, arrSlice, count0 As Long, i As Long, k As Long
    
    lastRow = 2  'the initial row where to paste
    Set shM = ActiveWorkbook.Sheets("MASTER")  'please, use here the appropriate sheet name
    shM.Range("A2:F10000").ClearContents
           
    For Each sh In ActiveWorkbook.Sheets
        If sh.Name <> shM.Name And sh.Name <> "TRACKING" Then             'if other sheets needs to be excepted, add them in the condition
            Set rng = sh.Range("K13:K42")         'the range being the reference for non zero values
            arrCopy = sh.Range("I13:N42").Value 'place all the range to be processed in an array, to make code faster
            count0 = Application.CountIf(rng, 0)   'count the zero values (even from formulas) to redim in the next row
            arr = rng.Value                     'place the reference range in an array (also, to make the code faster)
            If rng.Count - count0 = 0 Then GoTo OverProcessing
            ReDim arrRows(1 To rng.Count - count0, 1 To 1) 'redim the array to keep the row numbers without 0 in K:K
            k = 1: boolOK = False    'initialize the variable based on what the array keeping the rows to be copied is loaded
            For i = 1 To UBound(arr) 'iterate beteen the array elements
                 If arr(i, 1) <> 0 Then
                    arrRows(k, 1) = i: k = k + 1 'fill the rows to be copied number in the array
                    boolOK = True
                End If
            Next i
            If Not boolOK Then GoTo OverProcessing 'if there are only zero in all processed K:K range
            arrSlice = Application.Index(arrCopy, arrRows, Array(1, 2, 3, 4, 5, 6)) 'create a slice array keeping only the non zero rows
            'drop the slice array content at once:
            shM.Range("A" & lastRow).Resize(IIf(k = 2, UBound(arrRows), UBound(arrSlice)), 6).Value = arrSlice
            lastRow = shM.Range("A" & shM.Rows.Count).End(xlUp).Row + 1 'recalculate the last empty row
        End If
OverProcessing:
    Next
    MsgBox "Ready..."
End Sub

代码未经测试（工作原理除外），应该很快。请在测试后发送一些反馈。

推荐阅读