Transpose data from one sheet to other in particular format - AUD $20

MrRedli · May 25th 2017

Hi guys,
I have got bites of the code working fine already. However cannot figure how to transpose the data in columns in output 1. Hence I need a VBA code which can the following:

Copy BD in column A in “output 1” for all rows
Column B in "output 1" is counter which will have 1 to 48 for each date
Copy BC in column C in “output 1” for all rows
Column D in “Output 1” is row heading from “Raw Data” which needs to be replicated
Transpose data as below:
- If column BE starts with E, copy C to AX from raw data into column E in “Output 1”
- If column BE starts with Q, copy C to AX from raw data into column F in “output 1”
- If column BE starts with B, copy C to AX from raw data into column G in “output 1”
- If column BE starts with K, copy C to AX from raw data into column H in “output 1”
Copy formula from I2 to P2 to the last row in “Output 1”
Refresh the pivot table in column T in “Output 1”

have paid 2$ to OZgrid and will pay $20 to the person who completes the task. ETA Friday 26/05/2017 if possible.

**KjBox** · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

I can look at this for you.

**KjBox** · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Your code is done, I will PM you with my PayPal details.

MrRedli · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

payment sent

**KjBox** · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Payment received, many thanks.

I assumed that row 2 of the Raw Data was to be ignored as it does not contain data that is consistent with the rest of the dataset. The Pivot Table has to move to its own sheet otherwise the Output data cannot update.

I am attaching a file with the code working.

Your sample file only has "B" as the first letter in column BE of Raw Data so pivot table is empty and a full test could not be done for other letters ( E, Q and K), let me know if you have any issues with a complete set of data in Raw Data.

The code is in Module 3

Code

Sub Output()
    Dim x, y(), i As Long, ii As Long, iii As Long, iv As Integer, v As Integer
    
    x = Sheets("Raw Data").Cells(1).CurrentRegion
    For i = 3 To UBound(x, 1) - 1
        For ii = 1 To UBound(x, 2) - 9
            iii = iii + 1: ReDim Preserve y(1 To 8, 1 To iii)
            y(1, iii) = x(i, UBound(x, 2) - 1)
            y(2, iii) = ii
            y(3, iii) = x(i, UBound(x, 2) - 2)
            y(4, iii) = Format(CDate(x(1, ii + 2)), "hh:nn AM/PM")
            Select Case Left(UCase(x(i, UBound(x, 2))), 1)
                Case "E": y(5, iii) = CDbl(x(i, ii + 2))
                Case "Q": y(6, iii) = CDbl(x(i, ii + 2))
                Case "B": y(7, iii) = CDbl(x(i, ii + 2))
                Case "K": y(8, iii) = CDbl(x(i, ii + 2))
            End Select
        Next
    Next
    With Sheets("Output 1")
        .UsedRange.Offset(2).Clear
        .[a2].Resize(UBound(y, 2), 8) = Application.Transpose(y)
        i = .UsedRange.Rows.Count
        .[i2:p2].AutoFill .Range("i2:p" & i)
    End With
    ThisWorkbook.RefreshAll
    
End Sub

Display More

MrRedli · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Hi Charles I am getting an error at line as type miss match

Case "E": y(5, iii) = CDbl(x(i, ii + 2))

**KjBox** · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

That is probably due to the fact that the value of x(i, ii + 2) is not numerical.

Can you attach the file with the raw data that you are testing with, or e-mail it to me (same e-mail as PayPal ID) if you prefer.

MrRedli · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Hi Charles, just one note which forgot to mention, that if BC is blank it need to ignore that line.

MrRedli · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

email sent

**KjBox** · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Try changing the code to this, is it works then no need to attach or send the file.

Code

Sub Output()
    Dim x, y(), i As Long, ii As Long, iii As Long
    
    x = Sheets("Raw Data").Cells(1).CurrentRegion
    For i = 2 To UBound(x, 1) - 1
        If x(i, UBound(x, 2) - 2) <> vbNullString Then
            For ii = 1 To UBound(x, 2) - 9
                iii = iii + 1: ReDim Preserve y(1 To 8, 1 To iii)
                y(1, iii) = x(i, UBound(x, 2) - 1)
                y(2, iii) = ii
                y(3, iii) = x(i, UBound(x, 2) - 2)
                y(4, iii) = Format(CDate(x(1, ii + 2)), "hh:nn AM/PM")
                Select Case Left(UCase(x(i, UBound(x, 2))), 1)
                    Case "E"
                        If IsNumeric(x(i, ii + 2)) Then
                            y(5, iii) = CDbl(x(i, ii + 2))
                        Else
                            y(5, iii) = x(i, ii + 2)
                        End If
                    Case "Q"
                        If IsNumeric(x(i, ii + 2)) Then
                            y(6, iii) = CDbl(x(i, ii + 2))
                        Else
                            y(6, iii) = x(i, ii + 2)
                        End If
                    Case "B"
                        If IsNumeric(x(i, ii + 2)) Then
                            y(7, iii) = CDbl(x(i, ii + 2))
                        Else
                            y(7, iii) = x(i, ii + 2)
                        End If
                    Case "K"
                        If IsNumeric(x(i, ii + 2)) Then
                            y(8, iii) = CDbl(x(i, ii + 2))
                        Else
                            y(8, iii) = x(i, ii + 2)
                        End If
                End Select
            Next
        End If
    Next
    With Sheets("Output 1")
        .UsedRange.Offset(2).Clear
        .[a2].Resize(UBound(y, 2), 8) = Application.Transpose(y)
        i = .UsedRange.Rows.Count
        .[i2:p2].AutoFill .Range("i2:p" & i)
    End With
    ThisWorkbook.RefreshAll
    
End Sub

Display More

MrRedli · May 25th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

it now comes with error on below line:

.UsedRange.Offset(2).Clear

the error is 1004 : cant make this change for the selected cells because it will affect a PivotTable.

Also will the above line delete formula in cell I2:P2? as this should not be delete.

**KjBox** · May 26th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Note my previous post where I said pivot has to go on a separate sheet.

No the code will clear the used range offset by 2 rows, hence, the header row and the first row of data plus formulas do not get cleared.

As it happens I got your actual file and full dataset by e-mail in the end, I did not realise the data would be so big. Output 1 sheet ends up with almost 300,000 rows. I am having to find an efficient method of manipulating the data in stages because doing all in one shot deletes system resources!

I will post amended code shortly.

MrRedli · May 26th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Thanks for this, just a note the actual file can go out to 800K rows. the file I sent was a short version

**KjBox** · May 26th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

In that case you have a real problem!

800,000 rows of raw data would mean just short of 800,000 dates in the raw data.

Each date needs 48 rows in Output 1, that would mean over 38,000,000 rows on a sheet that has a maximum of 1,048,575 rows available for data below a header row!

The maximum rows of raw data that Excel alone could handle would therefore be 21,845.

I think you are going to have to look at using Access.

**KjBox** · May 26th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Hmmm you cannot mean 800,000 rows of raw data, that would be data collected for over 2,000 years, I am pretty certain you have not being doing that!

Raw Data that results in 800,000 rows on Output 1 would be OK, but note you are approaching the maximum.

MrRedli · May 26th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

no its 800K of result which gets pasted into output 1.

**KjBox** · May 26th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Here is the amended code.

The raw data is dealt with 1,000 rows at a time and Output 1 is updated after each block of 1,000 has been processed.

I will e-mail the file to you.

Code

Sub Output()
    Dim x, y(), i As Long, ii As Long, iii As Long, iv As Integer, v As Integer
    Dim wsRD As Excel.Worksheet, wsOP1 As Excel.Worksheet
    Set wsRD = Sheets("Raw Data"): Set wsOP1 = Sheets("Output 1")
    
    x = wsRD.Cells(1).CurrentRegion
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = 0
        .ScreenUpdating = 0
    End With
    On Error GoTo ErrHndlr
    wsOP1.UsedRange.Offset(2).Clear
    
    For iv = 1 To UBound(x, 1) Step 1000
        If iv = 1 Then v = 1000 Else v = iv + 999
        If v > UBound(x, 1) Then v = UBound(x, 1)
        iii = 0
        For i = iv To v
            If IsDate(x(i, UBound(x, 2) - 2)) Then
                For ii = 1 To UBound(x, 2) - 9
                    iii = iii + 1: ReDim Preserve y(1 To 8, 1 To iii)
                    y(1, iii) = x(i, UBound(x, 2) - 1)
                    y(2, iii) = ii
                    y(3, iii) = x(i, UBound(x, 2) - 2)
                    y(4, iii) = Format(CDate(x(1, ii + 2)), "hh:nn AM/PM")
                    Select Case Left(UCase(x(i, UBound(x, 2))), 1)
                    Case "E": y(5, iii) = CDbl(x(i, ii + 2))
                    Case "Q": y(6, iii) = CDbl(x(i, ii + 2))
                    Case "B": y(7, iii) = CDbl(x(i, ii + 2))
                    Case "K": y(8, iii) = CDbl(x(i, ii + 2))
                    End Select
                Next
            End If
        Next
        With wsOP1
            i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            If i = 3 Then i = 2
            .Cells(i, 1).Resize(UBound(y, 2), 8) = Application.Transpose(y)
        End With
    Next
    With wsOP1
        i = .UsedRange.Rows.Count
        .[i2:q2].AutoFill .Range("i2:q" & i)
    End With
    ThisWorkbook.RefreshAll
ErrHndlr:
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = 1
        .ScreenUpdating = 1
    End With


End Sub

Display More

MrRedli · May 27th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Thanks r this, it working fine now. However the date is coming up as text and hence my pivot is not showing this report properly. Can you please update this?

**KjBox** · May 27th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

Strange, it works fine for me.

Try changing this line in the code

Code

y(3, iii) = x(i, UBound(x, 2) - 2)

to

Code

y(3, iii) = CDate(x(i, UBound(x, 2) - 2))

MrRedli · May 27th 2017

Re: Transpose data from one sheet to other in particular format - AUD $20

this is not working as well. it copies the data but the pivot does not group them as its not in date format

Transpose data from one sheet to other in particular format - AUD $20

Participate now!

Share