Split on cell into various rows with VBA

[CLAASSJA2421]

Hi anyone,

I have a spreadsheet that pulls data from various other files and gives a report in of out of stock items at different clinics in one cell as below:

3	ATTERIDGEVILLE	July1E	Abacavir (ABC) (Aspen Abacavir) 300mg Tablet; 60 PT Ready Pack [PO]\Amethocaine 1% Cream; 25 g [TOP]\Benzoyl Peroxide 5% Gel; 40 g [TOP]\Bismuth Subgallate Co 22.5/8,75/8,75/12,5/ Ointment; 25 g [TOP]\Emulsifying (UE) BP Ointment; 500 g [TOP]\Lopinavir / Ritonavir (LPV/RTV) (Aluvia) 200/50mg Tablet; 120 PT Ready Pack [PO]
3	DANVILLE	July1E
2	DOORNPOORT	July1E
5	EAST LYNNE	July1E
3	FF RIBEIRO	July1E
3	FOLANG	July1E
3	GAZANKULU	July1E
3	HERCULES	July1E	Allopurinol 100mg Tablet; 28 PT Ready Pack [PO]\Beclomethasone Diproprionate 200mcg Inhaler; 200 Dose\Bismuth Subgallate Co 22.5/8,75/8,75/12,5/ Ointment; 25 g [TOP]\Calcium Carbonate, Glycine (Chewable) 420mg/180mg Tablet; 56 PT Ready Pack [PO]\Chlorpheniramine Maleate 4mg Tablet; 10 PT Ready Pack [PO]\Ferrous Sulphate Co (Sugar Coated) 200mg Tablet; 28 PT Ready Pack [PO]\Folic Acid 5mg Tablet; 28 PT Ready Pack [PO]\Ipratropium Bromide (Aerosol Oral Inhalation Metered Dose Complete Unit) 40mcg/dose Inhaler; 300 Dose [INH]\Lamivudine (3TC) (Cipla Lamivudine) 150mg Tablet; 60 PT Ready Pack [PO]\Mebendazole 100mg/5ml Suspension; 30 ml [PO]\Paracetamol 500mg Tablet; 20 PT Ready Pack [PO]\Sterile Water For Irrigation, Pour Bottle BP NA; 1000 ml [DIS]\Vaccine: BCG Intradermal, with Diluent BP Vial; 20 Dose [INJ]\Vaccine: Hepatitis B Peadiatric Vial; 10 Dose [INJ]\Zidovudine (AZT) (Retrovir) 50mg/5ml Syrup; 200 mL [PO]\Zinc Picolinate, Selenium & Vit C 200ml 1 Liquid, Internal; 200 ml [PO]

I have used "\" as the separator. I need to transpose theses columns into a new sheet listing all the items below each clinic, each item in a new line. Will this be possible?

I will really appreciate any help

[mancubus]

welcome to the forum.

i assume your table is in Sheet1 and does not have a header row, and new table will be in Sheet2.

try:

Sub vbax_53288_split_cell_as_new_rows()

    Dim i As Long, j As Long, k As Long
    Dim CellSplit
    
    Worksheets("Sheet2").Cells.Clear
    
    j = 1
    
    With Worksheets("Sheet1")
        For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
            If .Cells(i, 4) = "" Then
                Worksheets("Sheet2").Cells(j, 1).Value = .Cells(i, 1).Value
                Worksheets("Sheet2").Cells(j, 2).Value = .Cells(i, 2).Value
                Worksheets("Sheet2").Cells(j, 3).Value = .Cells(i, 3).Value
                j = j + 1
            Else
                CellSplit = Split(.Cells(i, 4), "\")
                For k = LBound(CellSplit) To UBound(CellSplit)
                    Worksheets("Sheet2").Cells(j, 1).Value = .Cells(i, 1).Value
                    Worksheets("Sheet2").Cells(j, 2).Value = .Cells(i, 2).Value
                    Worksheets("Sheet2").Cells(j, 3).Value = .Cells(i, 3).Value
                    Worksheets("Sheet2").Cells(j, 4).Value = CellSplit(k)
                    j = j + 1
                Next k
            End If
        Next i
    End With

End Sub

[CLAASSJA2421]

Hi mancubus

This works beautifully. I am attaching the file on which I am working. I am VERY new at vba and would appreciate if you could add an extra column to the new sheet that is transposed... I renamed the sheets to Sheet1 and Sheet2

SDBIP.xlsm


Many thanks

[mancubus]

you are welcome.

i dont understand the second requirement.
can you upload your workbook with Sheet2 having the desired output?

btw, you can use original sheet names.

[CLAASSJA2421]

Hi mancubus,

I saw how to change the sheet names thank you very much. I would just like to inquire if there is any way in which one can use a shortcut key like [Ctrl]+[Shift]+[N] to run the module?

Thank you again. You have saved me approximately 7 hours of work every Monday

[mancubus]

i would personally use a button. you can google with "excel vba insert button to sheet".


thanks google for saving me writing this.

Developer Tab, Code Group, Macros (or Alt and F8 keys).
Click Options
Select the macro in the box
Click Options.
Input n while pressing Shift key (Ctrl + letter for lowercase / Ctrl + Shift + letter for uppercase).
Click OK.
Click Cancel.

ps1: The shortcut key will override any equivalent default Microsoft Excel shortcut keys while the workbook that contains the macro is open.
ps2: The shortcut key cant use a number or special character, such as @ or #.
ps3: at first assignement you will see only Ctrl + button in the box. After inputting letter while pressing Shift button, you will see Ctrl + Shift + in the box


visual explanation:
http://www.wiseowl.co.uk/blog/s139/s...cros-excel.htm