从多个工作表的合并范围中提取文本

Question

我正在处理的工作簿中有 71 个工作表。我想从每个工作表中具有相同位置的合并范围中提取文本。

Sub extract_text()

    Application.ScreenUpdating = False
'copy current situation
    Sheets(ActiveSheet.Range("A1").Value).Select
    Range("F32:G44").Select
    Selection.Copy
    Sheets("combined").Select
    Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Range("B1").Select
'copy reasons
    Sheets(ActiveSheet.Range("A1").Value).Select
    Range("F45:G55").Select
    Selection.Copy
    Sheets("combined").Select
    Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Range("B2").Select
'copy solutions
    Sheets(ActiveSheet.Range("A1").Value).Select
    Range("F56:G64").Select
    Selection.Copy
    Sheets("combined").Select
    Range("B3").Select
    Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
End Sub

首先，我尝试使用简单的代码块来完成此操作，其中基于 A 列中的工作表名称，它将复制该特定工作表中的范围并将其粘贴到另一个名为“组合”的工作表中，但效果不佳，并且我不知道如何为其他工作表构建循环。我做了一些研究，但没有找到任何解决方案。

Answer 1

合并表格

Sub CombineSheets()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = wb.Sheets("Combined")
    
    Dim drg As Range:
    Set drg = dws.Range("A2", dws.Cells(dws.Rows.Count, "A").End(xlUp))
    
    Application.ScreenUpdating = False
    
    ' Clear 'B2:D1048576'
    drg.Resize(dws.Rows.Count - drg.Row + 1, 3).Offset(, 1).ClearContents
    
    Dim sws As Worksheet, dcell As Range
    
    For Each dcell In drg.Cells
        On Error Resume Next
            Set sws = wb.Sheets(CStr(dcell.Value))
        On Error GoTo 0
        If Not sws Is Nothing Then
            dcell.Offset(, 1).Value = sws.Range("F32").Value
            dcell.Offset(, 2).Value = sws.Range("F45").Value
            dcell.Offset(, 3).Value = sws.Range("F56").Value
            Set sws = Nothing ' reset for the next iteration
        End If
    Next dcell
    
    Application.ScreenUpdating = True

    MsgBox "Sheets combined.", vbInformation
 
End Sub