Is there a fast way to re-format and compile odd data in Excel using VBA or R?

I have over 200 sheets in an Excel workbook that are each formatted in a really odd way and I need to figure out how to compile all the data that I need into a single master sheet. I only need the values from certain cells and ranges (shown in the code below). I'd like the final compiled sheet to be in long-form (see attached image).

There is an attached image that is an example of the format of each sheet - it contains all the cells but does not contain any actual data. In reality, there is a lot of data - some sheets have >1000 rows.

I tried to use a function in R to read in all the sheets as separate data frames so that I could merge them but I couldn't get it to work. I then tried to use VBA, but I'm not familiar with the syntax. Here's what I came up with:

Sub Copy_Example()

  Dim J As Integer
    Dim s As Worksheet

    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add ' add a sheet in first place
    Sheets(1).Name = "Combined"

Worksheets("Sheet2").Range("D9").Copy Destination:=Worksheets("Combined").Range("A2")
Worksheets("Sheet2").Range("E2").Copy Destination:=Worksheets("Combined").Range("B2")
Worksheets("Sheet2").Range("E3").Copy Destination:=Worksheets("Combined").Range("C2")
Worksheets("Sheet2").Range("E4").Copy Destination:=Worksheets("Combined").Range("D2")
Worksheets("Sheet2").Range("E5").Copy Destination:=Worksheets("Combined").Range("E2")
Worksheets("Sheet2").Range("C22:C2000").Copy Destination:=Worksheets("Combined").Range("F1")
Worksheets("Sheet2").Range("E22:E2000").Copy Destination:=Worksheets("Combined").Range("G1")
Worksheets("Sheet2").Range("F22:F2000").Copy Destination:=Worksheets("Combined").Range("H1")
Worksheets("Sheet2").Range("G22:G2000").Copy Destination:=Worksheets("Combined").Range("I1")
Worksheets("Sheet2").Range("H22:H2000").Copy Destination:=Worksheets("Combined").Range("J1")
Worksheets("Sheet2").Range("I22:I2000").Copy Destination:=Worksheets("Combined").Range("K1")

End Sub

This VBA will copy and paste the correct columns and ranges into a newly created worksheet only for Sheet 2. I tried to integrate additional snippets of code so that this would run through all sheets in the workbook and paste the data below the last line previously added but I can't get it to work. I would also love to be able to add a column with the name of the sheet that the data has been copied from.

If anyone can help me with this, using either R or VBA, I would really appreciate it.

This is an example of the format of each sheet

This is an example of what I'd like the master compiled sheet to look like

Solution

Try the below code

Sub CopyToCombined()

    Dim oComWS As Worksheet, oWS As Worksheet
    Dim iLR As Long: iLR = 1

    ' Add New sheet as "Combined"
    Set oComWS = ThisWorkbook.Worksheets.Add
    oComWS.Name = "Combined"

    ' Loop through all sheets in the workbook and copy details in Combined sheet
    For Each oWS In ThisWorkbook.Worksheets
        If oWS.Name <> "Combined" Then
            With oWS
                oComWS.Range("A" & iLR).Value = .Range("A3").Value
                oComWS.Range("B" & iLR).Value = .Range("B5").Value
                oComWS.Range("C" & iLR).Value = .Range("C26").Value
            End With
            iLR = iLR + 1
        End If
    Next

End Sub

Above code will go through all sheets in your workbook and copy the relevant data (obviously you will have to change what you want to copy)

EDIT 1: As per requirement, below code should update the Combined as you requested

Sub CopyToCombined()

    Dim oComWS As Worksheet, oWS As Worksheet
    Dim iLR As Long: iLR = 1
    Dim iC As Long
    Dim aCleanArray As Variant, aMyRange As Variant, aColumn As Variant

    ' Add New sheet as "Combined"
    Set oComWS = ThisWorkbook.Worksheets.Add
    oComWS.Name = "Combined"

    ' Set arrays
    aMyRange = Array("C20:C50", "D20:D50")  ' <-- Set all your ranges here (i.e. "C22:C2000", "E22:E2000", ...)
    aColumn = Array("C", "D")               ' <-- Set the columns here (i.e. "F", "G", ...)

    ' Loop through all sheets in the workbook and copy details in Combined sheet
    For Each oWS In ThisWorkbook.Worksheets
        If oWS.Name <> "Combined" Then
            With oWS
                oComWS.Range("A" & iLR).Value = .Range("A2").Value
                oComWS.Range("B" & iLR).Value = .Range("B2").Value

                For iC = LBound(aMyRange) To UBound(aMyRange)
                    aCleanArray = CleanUpArray(.Range(aMyRange(iC)).Value)
                    oComWS.Range(aColumn(iC) & iLR & ":" & aColumn(iC) & (iLR + UBound(aCleanArray))).Value = Application.Transpose(aCleanArray)
                Next
            End With
            iLR = oComWS.Range(aColumn(0) & oComWS.Rows.Count).End(xlUp).Row + 1
        End If
    Next

End Sub

Function CleanUpArray(aIncomigArray As Variant) As Variant
    Dim aTemp() As Variant
    Dim iC As Long

    ReDim aTemp(0 To 0)

    For iC = LBound(aIncomigArray) To UBound(aIncomigArray)
        If Not IsEmpty(aIncomigArray(iC, 1)) Then
            aTemp(UBound(aTemp)) = aIncomigArray(iC, 1)
            ReDim Preserve aTemp(UBound(aTemp) + 1)
        End If
    Next

    ReDim Preserve aTemp(UBound(aTemp) - 1)
    CleanUpArray = aTemp

End Function

Hope this helps