We help IT Professionals succeed at work.

Reorganize complicated Excel File - relocate columns

wanderfuls
wanderfuls asked
on

Hello.

This might be a quite simple question to you, but it is quite complicated for me.
I have the attached excel with a list of patients filled with some parameters from testing equipment. To be more specific, we have a patient who comes to our office one day and we collect some data in six measurements. The patient visits our office another time and we repeat some measurements (2-6 measurements) recording the same dataset.
 
I want to be able to create a new table from this complicated one with the following characteristics:
- We will use only the following columns: C, D, K, L, M, N, O, AA, AB, AD, AE, AM, BV, BW, BX, BY, BZ, CO, CQ, CV, DC, DY.
- First of all we want the data to be sorted automatically by date and time on column D and then by column DY.
- Afterwards, for each appointment (certain day) we want ALL the data to be put in the SAME row. That is, we want data on column C, K, L, M, N, to be read once, and the rest of the desired columns to have the following format: D, O, DY, and then all the data collected on the specified time (column D) and position (column DY) (please see tab RESULTS on the attached excel to understand what I am saying).

If all these are understandable, please send me your comments.

It is a very crucial matter for me, because I must have this ready by Wednesday June 16, 2010.

Awaiting for your comments.
 Sphygmo-upload.xls
Comment
Watch Question

Top Expert 2015

Commented:
Okay if i understand correctly this is what you want to do, You want to combine all the records of the patient of the same day into one row. Thats what you want to do right?
Also one quick question is there changes that the numbers of rows for a particular patient comes into lets say 20 rows or something because you have column number restricted in excel in 2003 to 256 rows so if the data point is more then 256 the enitre activity will fail.
Saurabh...

Author

Commented:
1) You understand it correctly.
2) Will use only Excel 2007, and the max columns to be used are the ones on the RESULTS tab of the embedded excel.

Nikitas
Top Expert 2015

Commented:
Okay one last question, Your format of the raw data will remain constant as in same number of columns headers? and given in the same number of format as shown in your example?
Top Expert 2014

Commented:
This would be much better as a database application (MS-Access) than trying to do this in Excel.
Top Expert 2015

Commented:
Assuming your data will remain in same format as in same number of columns in the order you have uploaded in the example, Use the following code it will automatically create a worksheet with the name base which will have the format you are looking for..
Saurabh...

Sub copydata()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next
    Dim ws As Worksheet, ws1 As Worksheet
    Dim lrow As Long, srow As Long, k As Long
    Dim lcol As Long, lcol1 As Long
    Sheets("base").Delete
    Set ws = Sheets("HBP10_copy2_sup_sitONLY")
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Base"


    Set ws1 = Sheets("Base")

    ws.UsedRange.Copy ws1.Range("a1")

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

    ws1.Sort.SortFields.Clear
    ws1.Sort.SortFields.Add Key:=Range("C2:C" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws1.Sort.SortFields.Add Key:=Range("D2:D" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws1.Sort
        .SetRange Range("A1:DY" & lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    Columns("A:B").Delete
    Columns("C:H").Delete
    Columns("H:R").Delete
    Columns("M:S").Delete
    Columns("N:AU").Delete
    Columns("S:AF").Delete
    Columns("T:T").Delete
    Range("U:X,Z:AE").Delete
    Columns("W:AQ").Delete

    Columns("W:W").Cut
    Columns("H:H").Insert Shift:=xlToRight

    srow = 2

    k = srow

    Do Until srow > Cells(Cells.Rows.Count, "A").End(xlUp).Row

        If Cells(srow, 1).Value = Cells(srow + 1, 1).Value And Application.WorksheetFunction.Text(Cells(srow, 2).Value, "mm/dd/yy") = Application.WorksheetFunction.Text(Cells(srow + 1, 2).Value, "mm/dd/yy") Then
            lcol = Cells(srow, Cells.Columns.Count).End(xlToLeft).Column + 1
            Range(Cells(srow + 1, 1).Address & ":" & Cells(srow + 1, 23).Address).Copy Range(Cells(srow, lcol).Address)
            Rows(srow + 1).Delete
            lcol1 = Cells(srow, Cells.Columns.Count).End(xlToLeft).Column + 1
            Range("A1:W1").Copy Range(Cells(1, lcol).Address)
        Else
            srow = srow + 1
        End If
    Loop




    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Open in new window

Author

Commented:
Saurabh726:
- The format will remain constant
- and given in the same number of format as shown in your example? I don;t understand exactly what you are asking.

Aikimark:
- I know, but unfortunately must be in excel format.

Nikitas

Author

Commented:
@ Saurabh726:

Your code seems ok. I have to run some test tommorow and I will get back to you. I am almost sure that this is the solution we need.

Nikitas

Author

Commented:
@ Saurabh726:

1) The final remark would be that I would like ALL the titles of the columns to have an ascending order, that is the first SP title to stay intact, the second to be SP_2, the third SP_3 and so on.
2) I also would like NOT to repeat the PATIENT_NO, in every repeatance of the data and finally
3) I would like -if possible- another version of the code, that will put all the visits of the patients in the same row (i.e. different date visits)

Waiting for your reply
Nikitas
Top Expert 2015

Commented:
Nikitas,
Can you post me a sample file of results highlighting what changes you want from the code so that i can modify the code.
Saurabh...

Author

Commented:
Hello.

Please see changes on BASE & BASE 2nd VERSION worksheet.

Regards,
Nikitas
Sphygmo-upload-1.xls
Top Expert 2015

Commented:
There you go,Use this code...
Saurabh...

Sub copydata()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

   ' On Error Resume Next
       Dim rng As Range, z As Long
    Dim ws As Worksheet, ws1 As Worksheet
    Dim lrow As Long, srow As Long, k As Long
    Dim lcol As Long, lcol1 As Long, cell As Range
    Sheets("base").Delete
    Set ws = Sheets("HBP10_copy2_sup_sitONLY")
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Base"


    Set ws1 = Sheets("Base")

    ws.UsedRange.Copy ws1.Range("a1")

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

    ws1.Sort.SortFields.Clear
    ws1.Sort.SortFields.Add Key:=Range("C2:C" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws1.Sort.SortFields.Add Key:=Range("D2:D" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws1.Sort
        .SetRange Range("A1:DY" & lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    Columns("A:B").Delete
    Columns("C:H").Delete
    Columns("H:R").Delete
    Columns("M:S").Delete
    Columns("N:AU").Delete
    Columns("S:AF").Delete
    Columns("T:T").Delete
    Range("U:X,Z:AE").Delete
    Columns("W:AQ").Delete

    Columns("W:W").Cut
    Columns("H:H").Insert Shift:=xlToRight

    srow = 2
z = 2
    k = srow

    Do Until srow > Cells(Cells.Rows.Count, "A").End(xlUp).Row

        If Cells(srow, 1).Value = Cells(srow + 1, 1).Value And Application.WorksheetFunction.Text(Cells(srow, 2).Value, "mm/dd/yy") = Application.WorksheetFunction.Text(Cells(srow + 1, 2).Value, "mm/dd/yy") Then
            lcol = Cells(srow, Cells.Columns.Count).End(xlToLeft).Column + 1
            Range(Cells(srow + 1, 2).Address & ":" & Cells(srow + 1, 23).Address).Copy Range(Cells(srow, lcol).Address)
            Rows(srow + 1).Delete
          
            Range("b1:W1").Copy Range(Cells(1, lcol).Address)
              lcol1 = Cells(srow, Cells.Columns.Count).End(xlToLeft).Column + 1
           
              
              Set r = Range(Cells(1, lcol).Address & ":" & Cells(1, lcol1).Address)
              
              For Each cell In r
              cell.Value = cell.Value & " " & z
              Next cell
              z = z + 1
        Else
            srow = srow + 1
            z = 2
        End If
    Loop




    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Open in new window

Author

Commented:
I get en error:

Subscript out of range.

And no results of course. Any thoughts?
Top Expert 2015
Commented:
Ahh i thought so..
Replace line-5 which is this..
' On Error Resume Next

with this...
On Error Resume Next
Your entire code will become...this...
Saurabh...
 

Sub copydata()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

 On Error Resume Next
       Dim rng As Range, z As Long
    Dim ws As Worksheet, ws1 As Worksheet
    Dim lrow As Long, srow As Long, k As Long
    Dim lcol As Long, lcol1 As Long, cell As Range
    Sheets("base").Delete
    Set ws = Sheets("HBP10_copy2_sup_sitONLY")
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Base"


    Set ws1 = Sheets("Base")

    ws.UsedRange.Copy ws1.Range("a1")

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

    ws1.Sort.SortFields.Clear
    ws1.Sort.SortFields.Add Key:=Range("C2:C" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws1.Sort.SortFields.Add Key:=Range("D2:D" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws1.Sort
        .SetRange Range("A1:DY" & lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    Columns("A:B").Delete
    Columns("C:H").Delete
    Columns("H:R").Delete
    Columns("M:S").Delete
    Columns("N:AU").Delete
    Columns("S:AF").Delete
    Columns("T:T").Delete
    Range("U:X,Z:AE").Delete
    Columns("W:AQ").Delete

    Columns("W:W").Cut
    Columns("H:H").Insert Shift:=xlToRight

    srow = 2
z = 2
    k = srow

    Do Until srow > Cells(Cells.Rows.Count, "A").End(xlUp).Row

        If Cells(srow, 1).Value = Cells(srow + 1, 1).Value And Application.WorksheetFunction.Text(Cells(srow, 2).Value, "mm/dd/yy") = Application.WorksheetFunction.Text(Cells(srow + 1, 2).Value, "mm/dd/yy") Then
            lcol = Cells(srow, Cells.Columns.Count).End(xlToLeft).Column + 1
            Range(Cells(srow + 1, 2).Address & ":" & Cells(srow + 1, 23).Address).Copy Range(Cells(srow, lcol).Address)
            Rows(srow + 1).Delete
          
            Range("b1:W1").Copy Range(Cells(1, lcol).Address)
              lcol1 = Cells(srow, Cells.Columns.Count).End(xlToLeft).Column + 1
           
              
              Set r = Range(Cells(1, lcol).Address & ":" & Cells(1, lcol1).Address)
              
              For Each cell In r
              cell.Value = cell.Value & " " & z
              Next cell
              z = z + 1
        Else
            srow = srow + 1
            z = 2
        End If
    Loop




    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Open in new window

Author

Commented:
This solves the problem.

And for the final question, do you have a way to save all the data of a patient (different dates) in the same row? You have done too much up to now, so if this causes trouble, just tell me so.

Regards,
Nikitas
Top Expert 2015

Commented:
In case if you want to save all the data irrespecitve of dates then just change this line which is..line-54
 If Cells(srow, 1).Value = Cells(srow + 1, 1).Value And Application.WorksheetFunction.Text(Cells(srow, 2).Value, "mm/dd/yy") = Application.WorksheetFunction.Text(Cells(srow + 1, 2).Value, "mm/dd/yy") Then
to this..
 If Cells(srow, 1).Value = Cells(srow + 1, 1).Value Then
Saurabh...

Author

Commented:
I shoud give you 5000 points!!! Perfect expert :)