汇总表使用dynamic范围从多个工作表创build

我在工作簿中有176个工作表，它们都具有相同的格式/结构，但在行长度上有差异。

我想复制保存在范围A10中的数据：V（X）其中X是一个可计算的数字。 这些数据将被粘贴在彼此之下，在主表“B”中的B：W列中，并且每一行来自的表的名称将被粘贴到RDBMergeSheet的A列中，以便可以看到哪些行来自哪个床单

X =（列J中使用的最低行数） – 3

如果它更容易，计算X的另一种方法是find列A中包含单词“total”的行号，并从中减去1。

下面的链接包含了这样一个表格的例子，带有净化数据。

View post on imgur.com

到目前为止，我得到的代码是：

Sub ImportData() Dim x As Long Dim LR As Long Dim wks As Worksheet With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False End With Set wks = Sheets("RDBMergeSheet"): If Not wks Is Nothing Then wks.Delete Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count)) wks.Name = "RDBMergeSheet" For x = 1 To Worksheets.Count - 1 LR = Application.Max(1, Sheets(x).Cells(Rows.Count, 10).End(xlUp).Row - 3) With wks.Cells(Rows.Count, 1) .Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value .Offset(1).Resize(LR - 9).Value = Sheets(x).Name End With Next x wks.Select With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False End With Set wks = Nothing End Sub 

这个错误与1004：应用程序定义或对象定义的错误在线

 .Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value 

如果有人对如何解决这个问题有什么想法，我会非常感激。

Answer 1

请按照您的要求尝试并调整它，以确保从目标工作表上正确的行开始复制正确的数据。

 Sub ImportData() Dim LR As Long, dLR As Long, i As Long Dim wks As Worksheet With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False End With On Error Resume Next Set wks = Sheets("RDBMergeSheet") wks.Cells.Clear On Error GoTo 0 If wks Is Nothing Then Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count)) wks.Name = "RDBMergeSheet" End If For i = 1 To Worksheets.Count - 1 If Worksheets(i).Name <> wks.Name Then LR = Application.Max(1, Sheets(i).Cells(Rows.Count, 10).End(xlUp).Row - 3) If LR > 9 Then If wks.Range("B1").Value = "" Then dLR = 1 Else dLR = wks.UsedRange.Rows.Count + 1 End If wks.Range("B" & dLR & ":X" & LR - 9).Value = Worksheets(i).Range("B10:X" & LR).Value wks.Range("A" & dLR).Value = Worksheets(i).Name End If End If Next i On Error Resume Next wks.Select dLR = wks.UsedRange.Rows.Count wks.Range("A1:A" & dLR).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C" wks.Range("A1:A" & dLR).Value = wks.Range("A1:A" & dLR).Value With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True .DisplayAlerts = True End With Set wks = Nothing End Sub