How to setup macro to reformat data

jakeman

jakeman

Active Member
Joined
Apr 29, 2008
Messages
325
Office Version
  1. 365
Platform
  1. Windows
Hi there - I'm not sure how to go about this problem. I have an existing table of data that is in a format which is not very usable. I want to reformat the data in a manner that requires a little bit of coding, otherwise I'll need to do data entry and that will take a long time.

Currently my data is in this format:





However, I want to have the information in this format instead:



I am trying to create a macro that will step through each Study Number and as many entries there are for a month, to poplulate a table with the date, Study Number, Type of Prep, Difficulty, RadioLabeled, and finally the count. Essentially, this would be like a loop statement that will copy all of these fields for each Study until all dates have been copied, and then move on to the next study until all have been copied over.

Can anyone help with where to start with putting such a code statement together?
 
Last edited:

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
otherwise I'll need to do data entry and that will take a long time
Click to expand...

While images are nice, it requires most anyone working on a solution "to do data entry..." You might get more responses if you post data that can be copied/pasted into excel.

Cheers,

tonyyy
 
Upvote 0
You're right! Here is the data in my existing format.

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Study Number[/TD]
[TD]10010[/TD]
[TD]10020[/TD]
[TD]10030[/TD]
[/TR]
[TR]
[TD]Type of Prep[/TD]
[TD]32A[/TD]
[TD]33B[/TD]
[TD]32A[/TD]
[/TR]
[TR]
[TD]Difficulty[/TD]
[TD]Standard[/TD]
[TD]Complex[/TD]
[TD]Complex[/TD]
[/TR]
[TR]
[TD]RadioLabeled?[/TD]
[TD]No[/TD]
[TD]No[/TD]
[TD]Yes[/TD]
[/TR]
[TR]
[TD]Date[/TD]
[TD]Doses[/TD]
[TD]Doses[/TD]
[TD]Doses[/TD]
[/TR]
[TR]
[TD]1/1/2018[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]18[/TD]
[/TR]
[TR]
[TD]1/2/2018[/TD]
[TD]32[/TD]
[TD]16[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]1/4/2018[/TD]
[TD]15[/TD]
[TD]11[/TD]
[TD]10[/TD]
[/TR]
</tbody>[/TABLE]














Now I'd like it to be formatted to look like the following table:

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Date[/TD]
[TD]Study Number[/TD]
[TD]Type of Prep[/TD]
[TD]Difficulty[/TD]
[TD]RadioLabeled[/TD]
[TD]Doses[/TD]
[/TR]
[TR]
[TD]1/1/2018[/TD]
[TD]10010[/TD]
[TD]32A[/TD]
[TD]Standard[/TD]
[TD]No[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]1/2/2018[/TD]
[TD]10010[/TD]
[TD]32A[/TD]
[TD]Standard[/TD]
[TD]No[/TD]
[TD]32[/TD]
[/TR]
[TR]
[TD]1/4/2018[/TD]
[TD]10010[/TD]
[TD]32A[/TD]
[TD]Standard[/TD]
[TD]No[/TD]
[TD]15[/TD]
[/TR]
[TR]
[TD]1/1/2018[/TD]
[TD]10020[/TD]
[TD]33B[/TD]
[TD]Complex[/TD]
[TD]No[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]1/4/2018[/TD]
[TD]10020[/TD]
[TD]33B[/TD]
[TD]Complex[/TD]
[TD]No[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]1/2/2018[/TD]
[TD]10030[/TD]
[TD]32A[/TD]
[TD]Complex[/TD]
[TD]Yes[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]1/4/2018[/TD]
[TD]10030[/TD]
[TD]32A[/TD]
[TD]Complex[/TD]
[TD]Yes[/TD]
[TD]10[/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
jakeman,

Thanks for the data. You might consider the following...

Code: 
Sub TransposeArray_1063501()
Dim LastRow As Long, LastCol As Long
Dim arr1 As Variant, arr2() As Variant
Dim newRows As Double
Dim r As Long, c As Long, i As Long

Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells.Find(What:="*", after:=Cells(1, 1), LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
LastCol = ActiveSheet.Cells.Find(What:="*", after:=Cells(1, 1), LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
arr1 = Range(Cells(1, 1), Cells(LastRow, LastCol))
newRows = WorksheetFunction.CountA(Range(Cells(6, 2), Cells(LastRow, LastCol)))
ReDim arr2(1 To newRows, 1 To 6)
i = 1

For r = 6 To UBound(arr1)
    For c = 2 To UBound(arr1, 2)
        If arr1(r, c) <> "" Then
            arr2(i, 1) = arr1(r, 1)
            arr2(i, 2) = arr1(1, c)
            arr2(i, 3) = arr1(2, c)
            arr2(i, 4) = arr1(3, c)
            arr2(i, 5) = arr1(4, c)
            arr2(i, 6) = arr1(r, c)
            i = i + 1
        End If
    Next c
Next r

Sheets.Add after:=Sheets(Sheets.Count)
With ActiveSheet
    .Range("A2:F" & newRows + 1).Value = arr2
    .Range("A1:F1").Value = Split("Date,Study Number,Type of Prep,Difficulty,RadioLabeled,Doses", ",")
    .Columns.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "The dishes are done, dude!"
End Sub
Cheers,

tonyyy
 
Upvote 0
I'm going to try this out on the real thing but I gotta good feeling this will work, in which case my "dishes are done, man."

70d926c8a0dc468cb9a0d0ee4e26a363.gif
 
Upvote 0
Hey tonyyy - thanks for the code you supplied. I'm trying to adapt it to the exact scenario I need it for but I'm having some troubles that maybe you can help me with, if so inclined.

I have on one sheet 12 tables for each month, which I would like to individually copy/paste values from and paste to a consolidated table called YTD_Details. For now, I'm only concerned with transposing January data. The problem I'm having is that the table is creating several blank rows after the last row of data. Total number of rows in the table is equal to the newRows count, which in this case is 108. So from what I can tell, whenever cells within the newRows variable are blank, those becomes blank rows in my table. Don't know if you can try the code on your end and reproduce the issue. I'd sure be grateful if you could test it out.

Secondly, if there is already data in my table, ideally I would like to move to the next blank row and append data there. I don't think I understand your code well enough to figure out how to do that, but if you could explain what it's doing, maybe I could figure it out myself.

Thanks.
Code: 
Sub TransposeArray_January()
Dim LastRow As Long, LastCol As Long
Dim arr1 As Variant, arr2() As Variant
Dim newRows As Double
Dim r As Long, c As Long, i As Long

Application.ScreenUpdating = False

LastRow = 39
LastCol = 21

arr1 = Range(Cells(4, 1), Cells(LastRow, LastCol)) 'Assigning the entire list of rows and columns that part of the range of cells needed to transpose to table

newRows = WorksheetFunction.CountA(Range(Cells(6, 2), Cells(LastRow, LastCol)))

ReDim arr2(1 To newRows, 1 To 6)

i = 1

For r = 6 To UBound(arr1)
    For c = 2 To UBound(arr1, 2)
        If arr1(r, c) <> "" Then
            arr2(i, 1) = arr1(r, 1)
            arr2(i, 2) = arr1(1, c)
            arr2(i, 3) = arr1(2, c)
            arr2(i, 4) = arr1(3, c)
            arr2(i, 5) = arr1(4, c)
            arr2(i, 6) = arr1(r, c)
            i = i + 1
        End If
    Next c
Next r

Sheets("Details").Select

N = Cells(Rows.Count, "A").End(xlUp).Row

With ActiveSheet
    .Range("A" & N & ":" & "F" & newRows + 1).Value = arr2
    .Columns.AutoFit
End With

Application.ScreenUpdating = True

End Sub
 
Upvote 0
The problem I'm having is that the table is creating several blank rows after the last row of data. Total number of rows in the table is equal to the newRows count, which in this case is 108. So from what I can tell, whenever cells within the newRows variable are blank, those becomes blank rows in my table. Don't know if you can try the code on your end and reproduce the issue. I'd sure be grateful if you could test it out.
Click to expand...

The code was tested against the sample data. If the sample isn't representative of the actual data then the results may differ.

That said, you're right to suspect the newRows variable...

Code: 
newRows = WorksheetFunction.CountA(Range(Cells(6, 2), Cells(LastRow, LastCol)))

From the help file: The COUNTA function counts the number of cells that are not empty in a range. So newRows is the count of all the doses in Range(Cells(6,2), Cells(LastRow, LastCol)). If the Blank cells in the range are not blank, eg, if they contain a formula or other hidden text, then newRows will include those in the count... and the transformed data will include blank rows.

Let me know if this is indeed the case, then we can replace the newRows calculation with something else.
 
Upvote 0
Thanks, tonyyy. The sample data is representative of the actual data, it's just that the actual data contains more information and I had to adjust where the data begins and ends, that type of thing.

Let me just back up for one second and try to lay out what I'm trying to do. So your code works well when I use a table to transpose the data, but if I convert the table to a range, once data is transposed, the headers for the columns are wiped out. But for right now, I'm happy using a table actually.

But here is my dilemma. I want to be able to transpose data to my table but if there already exists data there, I want the information to be copied to the very next line. My problem right now is that this isn't happening and I've tried to code for that, but I can't seem to get it to work. Partly because I don't fully understand how your code works. Here is the code that I modified:

Code: 
Sub TransposeArray_January()
Dim LastRow As Long, LastCol As Long
Dim arr1 As Variant, arr2() As Variant
Dim newRows As Double
Dim Rng As Range
Dim r As Long, c As Long, i As Long

Application.ScreenUpdating = False

LastRow = 39
LastCol = 21

arr1 = Range(Cells(4, 1), Cells(LastRow, LastCol)) 'Assigning the entire list of rows and columns that part of the range of cells needed to transpose to table

newRows = WorksheetFunction.CountA(Range(Cells(6, 2), Cells(LastRow, LastCol)))

ReDim arr2(1 To newRows, 1 To 6)

i = 1

For r = 6 To UBound(arr1)
    For c = 2 To UBound(arr1, 2)
        If arr1(r, c) <> "" Then
            arr2(i, 1) = arr1(r, 1)
            arr2(i, 2) = arr1(1, c)
            arr2(i, 3) = arr1(2, c)
            arr2(i, 4) = arr1(3, c)
            arr2(i, 5) = arr1(4, c)
            arr2(i, 6) = arr1(r, c)
            i = i + 1
        End If
    Next c
Next r

Sheets("Details").Select

N = Cells(Rows.Count, "B").End(xlUp).Row

With ActiveSheet
    .Range("B" & N & ":" & "G" & newRows + 1).Value = arr2
    .Columns.AutoFit
End With

On Error Resume Next
Set Rng = Range("YTD_Details[[Date]]").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not Rng Is Nothing Then
    Rng.Delete Shift:=xlUp
End If

Application.ScreenUpdating = True

End Sub

Note that I hard-coded the values for LastRow and LastCol.

Also, variable "N" is meant to count the number of used cells in Column B of the Details sheet, which is where I want to copy and paste my data.

I appreciate your help, tonyyy.
 
Last edited:
Upvote 0
Code: 
Sub TransposeArray_January()
Dim LastRow As Long, LastCol As Long
Dim arr1 As Variant, arr2() As Variant
Dim newRows As Double
Dim Rng As Range
Dim r As Long, c As Long, i As Long, [COLOR=#ff0000]n As Long[/COLOR]

Application.ScreenUpdating = False

LastRow = 39
LastCol = 21

arr1 = Range(Cells(4, 1), Cells(LastRow, LastCol)) 'Assigning the entire list of rows and columns that part of the range of cells needed to transpose to table

newRows = WorksheetFunction.CountA(Range(Cells(6, 2), Cells(LastRow, LastCol)))

ReDim arr2(1 To newRows, 1 To 6)

i = 1

For r = 6 To UBound(arr1)
    For c = 2 To UBound(arr1, 2)
        If arr1(r, c) <> "" Then
            arr2(i, 1) = arr1(r, 1)
            arr2(i, 2) = arr1(1, c)
            arr2(i, 3) = arr1(2, c)
            arr2(i, 4) = arr1(3, c)
            arr2(i, 5) = arr1(4, c)
            arr2(i, 6) = arr1(r, c)
            i = i + 1
        End If
    Next c
Next r

Sheets("Details").Select

n = Cells(Rows.Count, "B").End(xlUp).Row
[COLOR=#ff0000]If Cells(n, 2) = "" Then
    n = Cells(Rows.Count, "B").End(xlUp).End(xlUp).Row + 1
Else
    n = Cells(Rows.Count, "B").End(xlUp).Row + 1
End If[/COLOR]

With ActiveSheet
    .Range("B" & n & ":" & "G" & newRows + 1).Value = arr2
    .Columns.AutoFit
End With

On Error Resume Next
Set Rng = Range("YTD_Details[[Date]]").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not Rng Is Nothing Then
    Rng.Delete Shift:=xlUp
End If

Application.ScreenUpdating = True

End Sub

The .End(xlUp).Row will typically find the last row with data; when using a Table, however, it finds the last row in the Table, regardless if it contains data or not. The lines in red should account for this. (You may want to implement something similar where you have hard coded "LastRow = 39".
 
Upvote 0
I think this is working just fine for me now. Thanks for your help, tonyyy!

Just curious, did you build this code yourself or have you encountered this before?
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Question Question
Formatting raw data with extra rows automatically added in-between records
Replies
1
Views
79
Peter_SSs
Peter_SSs
A
  • Question Question
Adjusting data in cell
2
Replies
13
Views
634
Joe4
Joe4
L
  • Question Question
Macro to correct entries across multiple sheets
Replies
1
Views
210
Lux Aeterna
L
R
  • Question Question
Create Data Entry form based on Data from another Sheet
Replies
1
Views
169
Umma123
U
J
  • Question Question
Conditional formatting of single column of pivot table
Replies
8
Views
342
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,823
Messages
6,181,182
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top