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

Question

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

From what i can see, you are only copying to **Sheet2**. What are these `additional snippets` that you tried?. You could simply loop through all sheets in your workbook using a loop: `For Each oWS In Thisworkbook.Worksheets` (where `oWS` is a `Worksheet` variable) — Zac, Jun 10 '20 at 15:54
@Zac I tried to use this instead but it wasn't working: `For Each s In ActiveWorkbook.Worksheets` `If s.Name <> Combined.Name Then` `Set CopyRng = s.Range("D9", "E2" "E3", etc)` — alliecat966, Jun 10 '20 at 15:58
I also tried just putting `For Each s In ActiveWorkbook.Worksheets` `If s.Name <> Combined.Name Then` above the code in the description above and that didn't work either. — alliecat966, Jun 10 '20 at 16:05
Try changing your `IF` statement to: `If s.Name <> "Combined" Then` — Zac, Jun 10 '20 at 16:14
That creates the combined data sheet and puts all the correct cells in the correct spot but only from Sheet 2. What do I need to change so that `Worksheets("Sheet2").Range("D9").Copy Destination:=Worksheets("Combined").Range("A2")` refers to all worksheets instead of just "Sheet 2"? When I use `Set CopyRng = s.Range("D9", "E2" "E3", etc)` the code just doesn't run at all. — alliecat966, Jun 10 '20 at 16:26

Zac · Accepted Answer · 2020-06-15T14:39:03.407

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

This almost works! It copies and pastes that data that is in only one cell (Ex. D9=Name) perfectly. It doesn't copy the columns that have ranges (it would need to create more than one row of data corresponding to each participant; Ex. "C22:C2000"). Is there a way to fix that? — alliecat966, Jun 11 '20 at 18:30
Are you expecting more than 1 line per patient? I'm presuming that your sheet with original data only holds data for 1 patient? I cant see that in the screen print you provided — Zac, Jun 12 '20 at 15:38
No! Each sheet is data for a separate person and while all of the columns are named the same way and are in the same location, they are not all the same number of rows. — alliecat966, Jun 12 '20 at 18:42
As each patient can have multiple rows, we need to cater for that. I will post something as and when i get some time. If you can't wait, you could try capturing your range for each patient in and array, removing blanks and then pasting the array — Zac, Jun 15 '20 at 09:20

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

1 Answers1