Extracting text from a merged range in multiple sheets

Question

There are 71 worksheets in the workbook I am working on. I want to extract the text from a merged range which have the same location in each sheet.

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

First I tried to do it with simple blocks of code in which based on the sheet name in column A, it will copy the range in that specific sheet and paste it in another sheet called "combined" but it doesn't work well and I don't know how to build a loop for the other worksheets. I have done some research but haven't found any solutions.

Answer 1

Combine Sheets

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

Answer 2

you could avoid VBA and use INDIRECT() formula

see attached pictures for first row, then just drag it down

Answer 3

• The header row and the first column (sheet name) are populated by VBA. You won't need to update sheet name on the first column if more sheets are added to your file.

Microsoft documentation:

ReDim statement

Range.Resize property (Excel)

Sheets.Add method (Excel)

Option Explicit
Sub Demo()
    Const CMB_SHT = "Combined"
    Dim oShtCmb As Worksheet, oSht As Worksheet
    Dim arrRes, iR As Long
    On Error Resume Next
    Set oShtCmb = Sheets(CMB_SHT)
    On Error GoTo 0
    If oShtCmb Is Nothing Then
        ' add a new sheet
        Set oShtCmb = Sheets.Add
        oShtCmb.Name = CMB_SHT
    Else
        ' clear existing sheet
        oShtCmb.Cells.Clear
    End If
    ReDim arrRes(1 To ThisWorkbook.Worksheets.Count - 1, 1 To 4)
    ' loop through sheet
    For Each oSht In ThisWorkbook.Worksheets
        If oSht.Name <> CMB_SHT Then
            ' get the contents
            iR = iR + 1
            arrRes(iR, 1) = oSht.Name
            arrRes(iR, 2) = oSht.Range("F32").Value
            arrRes(iR, 3) = oSht.Range("F45").Value
            arrRes(iR, 4) = oSht.Range("F56").Value
        End If
    Next
    ' create header
    oShtCmb.Range("A1").Resize(1, 4).Value = Array("Sheet_name", "Situation", "Reason", "Solution")
    ' write output to sheet
    oShtCmb.Range("A2").Resize(iR, 4).Value = arrRes
End Sub