Copy cells going down a column with the same patient number to a single row.

Attached is a spreadsheet that has two worksheets (Original and Finished) that has patient numbers listed in column A with Diagnosis codes in column J. What I need to figure out is how to copy or cut the Dx codes for the same patient into first row that lists the patient number. In the worksheet 'Original' I would need to copy or cut J3 and paste into K2 and J4 into L2, J5 into M2 ... The finished information should look like the 'Finished' worksheet. Thank-you for your help in advanced.

I'm getting a Compile error: Syntax error at: Cells(KRowCtr, Cells(KRowCtr, Columns.Count).End(xlToLeft).Column + 1) = _

Cells(ARowCtr, "J")

Hi kschaefer,
. The code from Bailey_Thomas came very close. (That syntax error was obvious: just an extra line there in between. - As it was one code line separated with a _ there must not be any empty line between the two parts of the same code line.

….anyways here is my go. It seems to work. There are a lot of messy green comments on it, mainly for my benefit as I am learning as I go along answering these sort of Threads. But you can easily edit them off and edit other bits as you chose….

Option Explicit 'Not necerssary but good practice to keep computer memery usage to minimum (and helps show up errors)
Sub PatientSortin()
Dim wks1 As Worksheet: Set wks1 = ThisWorkbook.Worksheets("Original"): wks1.AutoFilterMode = False

'    'Delete all sheets except Sheet1 option
'    Dim wsTemp As Worksheet
'    Application.DisplayAlerts = False
'    For Each wsTemp In ActiveWorkbook.Worksheets
'        If wsTemp.Name <> wks1.Name Then wsTemp.Delete
'    Next
'    Application.DisplayAlerts = True

    'Make Array of unique Patient names----
    Const TempVertClm = 11 'Temporary Column to use for unique array (will be deleted later)
    Const VLkUpClm = 1 'Look Up Column for Unique values (Patient Numbers in this case are in First column)
    Let wks1.Cells(1, TempVertClm).Value = "Patient NUMBER" 'Just for fun Put "patient NUMBER"
    Dim sht1Rows As Long 'Rows in First Sheet
    Dim lr As Long: Let lr = wks1.Cells.Find(What:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' You start at first cell then go backwards (which effectively starts at end of sheet. This allows for different excel versions with different available Row numbers)
        For sht1Rows = 2 To lr 'Go througth all rows in sheet1
        On Error Resume Next
            If wks1.Cells(sht1Rows, VLkUpClm).Value <> "" And Application.WorksheetFunction.Match(wks1.Cells(sht1Rows, VLkUpClm), wks1.Columns(TempVertClm), 0) = 0 Then 'If grub Row is not empty and that value does not (yet) match any same value in entire Column of tempory vertical column
            wks1.Cells(wks1.Rows.Count, TempVertClm).End(xlUp).Offset(1).Value = wks1.Cells(sht1Rows, VLkUpClm).Value 'Then put that value in the tempory Column at next free Row
            End If
        Next sht1Rows
    Dim UniqueArr() As Variant 'Must be variant as it sees Object Application initially in next line
    Let UniqueArr() = wks1.Range("A1").Range(wks1.Cells(1, TempVertClm), wks1.Cells(wks1.Cells(wks1.Rows.Count, TempVertClm).End(xlUp).Row, TempVertClm)).Value
    Let UniqueArr() = Application.WorksheetFunction.Transpose(UniqueArr)
                     'Let UniqueArr = Application.WorksheetFunction.Transpose(wks1.Columns(TempVertClm).SpecialCells(xlCellTypeConstants)) 'This  transposes the Array to give a list of columns. .SpecialCells(xlCellTypeConstants) is convenient way to get rid of the empty rows. I DO NOT UNDERSTAND IT YET
    wks1.Columns(TempVertClm).Delete 'Delete is better than clear to avoid possble pronlems later >> http://www.mrexcel.com/forum/excel-questions/787428-clear-delete-shift-%3Dxlup-let-y-%3D-y-%96-1-usedrange-rows-count-anomale.html
    'End of making Patient name list-------
   
   Dim ArrClm As Long 'Row from Temp Unique Column transposed as columns (= patient numbe +1 as array has Header in)
   Dim NewStRw As Long, OldStRw As Long: Let OldStRw = 2 'Variables for current and last rows where transposed list should go. Is also variables for range start and stop cell for Filtered list
      For ArrClm = 2 To UBound(UniqueArr) 'Going through every Patient Unique Number (from second to last entry in the patient Number array
  
      wks1.Range("a1:j" & lr & "").AutoFilter Field:=VLkUpClm, Criteria1:="" & UniqueArr(ArrClm) & "" 'This results in only Records with critical value in column 1 being seen in main sheet
      wks1.Range("a1:j" & lr & "").SpecialCells(xlCellTypeVisible).Copy Destination:=wks1.Range("K" & OldStRw - 1 & "") ', then combine it with SpecialCells to just copy that wot you see, (and then send it to the relavent new sheet , name n).. ( Idid notice that it works the same without the .SpecialCells(xlCellTypeVisible) bit, - but that mayjust be Excel “guessing wot you want” as it does, that is to say it copies by default wot is visible
      wks1.AutoFilterMode = False 'This makes everything visible again in main sheet. - (Usually done once at the end, but useful for debuggung purposes to do within loop)
      Let NewStRw = wks1.Cells(Rows.Count, 11).End(xlUp).Row
      wks1.Range("T" & OldStRw & ":T" & NewStRw & "").Copy 'Copy
      wks1.Range("U" & OldStRw & "").PasteSpecial Transpose:=True 'Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= False, Transpose:=True
      Let OldStRw = NewStRw + 1 'Next patient DX codes will start in row after the last patients DX codes
      Next ArrClm 'Go to next patient
'wks1.AutoFilterMode = False'This is where it is usually done.
wks1.Columns("J:T").Delete Shift:=xlToLeft
wks1.Range("J1").Value = "DX" 'oops I chopped the DX off- so I put it back!!
End Sub 'PatientSortin

…… and here is your returned file (Saved on XL2007 as .xlsm ) Macro in Macro Module “Alan”:
https://app.box.com/s/7idndjz9x6wszm85fnw2
.. also attatched..

…………………………………………………………………………………………………………………………………………………..

Hi Bailey_Thomas,
. I work through a lot of people’s codes, learning as I go along. I learnt a new way to get at the unique values with the .RemoveDuplicates, bit. Thanks. I learn the most from Threads where people give different solutions to the same problem. (Amazingly close effort as you were not at your computer!)

Hi again kschaefer,
. I am a bit new in this Forum, Excel Forum, and I am afraid do not quite know my way around. – It just occurred to me that you are in the Excel General Sub Forum and so may not be looking for a VBA solution at all! - Thinking about it you may not have a massive amount of Patients? - so a manual solution might be better, just one to reduce tediously copying every single cell.

. So. To do this. Taking your first set of patients as an example. (I assume you have XL 2007 or above as you sent a .xlsx File)
.1) Highlight Range J2 to J12 (mouse Left Click in Cell J2 and while holding left mouse down drag cursor to cellJ12)
.2) Copy that selected range to Clipboard (Ctrl C or click on the symbol for copying to clipboard above left in the Start(Home maybe in English?) Ribbon)
.3 ) Select cell K2. (Left click mouse in cell K2)
.4 ) Select the pull down options under Insert above left in the Start(Home) ribbon.
.5 ) Choose the option which in XL2007 in English I guess is something like Transpose (XL 2010 has a symbol with two small rectangle boxes and a curved arrow demonstrating a 90 degree rotation).
.6 ) You should now have the First Patients entry looking similar to wot you want.
.7 ) Repeat the above for all patients.
.8 ) Select the entire J Column (Click on small J box above the column)
.9 ) Delete that entire J column (Click on the Delete Symbol above a bit right from center in the Start Ribbon to delete the entire column (not just what is in it))
.10) Re-type in “DX” in first J cell.

Alan
Bavaria

P.s. 1) The above steps (1 – 9) is wot I did as I “cheated” to get part of the code I supplied by recording the above steps ( 1 -9) as I did it using the macro recorder! (This macro recorder produces automatically a crude VBA code based on the actions you are taking as the recorder is switched on.)

P.s. 2) One advantage of my code is that the Patient order can all be jumbled up, and it still works to give you the Output Lines that you want. (There remains then the question of where you want those Output Lines. In this case the format that Bailey_Thomas’s code gives might be appropriate – There the list You want is given alongside The Patient Numbers. My code could be easily modified to do that as well. Let me know if You want to do that and need any help). (My code would put the Output Row somewhere around the average position for mixed up patient Order)

Here's another approach if you could use a formula.

This array formula entered into J2.....committed not as regular formulas but by pressing and holding Ctrl + Shift then hitting Enter.

You'll know it's entered correctly when you see {} curly braces around the formula in the formula bar. You don't type these in yourself...Excel does it for you. Once committed drag-fill down to U23 or as far down as you have data and right until blank cells are all you get.

The file is attached; solution is on Finished2 sheet.

Formula:

=IFERROR(IF($A2=$A1,"",INDEX(Original!$J$2:$J$23,SMALL(IF($A2=Original!$A$2:$A$23,ROW(Original!$A$2:$A$23)-MIN(ROW(Original!$A$2:$A$23))+1),COLUMNS($A:A)))),"")

Here's another, shorter / simpler array formula....committed and filled down and across the same way.

Formula:

=IFERROR(IF($A2=$A1,"",INDEX(IF($A2=Original!$A2:$A$23,Original!$J2:$J$23,""),COLUMNS($A:A))),"")

@Doc.AElstein







@Doc.AElstein

(P.s. great to have the attachment - the formula comes up automatically translated. Up to now I have always had to translate them from the English Screen shots…(But it was / is all good practice as well I suppose!)

If you need...
http://excel-translator.de/

Originally Posted by Indi_Ra

..........

If you need...
http://excel-translator.de/

Super!
. I had been looking for something like that.
. I just tried it. It is not perfect as it does not appear to change the commas for semicolons and vice versa. But it does change the commands, so that is a great help.

Many Thanks
Alan