Question

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

我想复制范围A10：V（X）中的数据，其中X是可计算的数字。这些数据将粘贴在彼此之下，在主要表格的列B：W中;＆＃34; RDBMergeSheet＆＃34;并且每行来自的工作表的名称将被粘贴到RDBMergeSheet的A列中，以便可以看到哪些行来自哪些工作表

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

如果它更容易，另一种计算X的方法是在A列中找到包含单词＆＃34; total＆＃34;的行号。并从中减去1。

以下链接包含此类工作表的示例，其中包含已清理的数据。

https://imgur.com/a/emlZj

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

    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

使用动态范围

1 个答案: