PDA

View Full Version : Split on cell into various rows with VBA



CLAASSJA2421
07-27-2015, 12:27 AM
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
07-27-2015, 05:03 AM
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
07-27-2015, 05:57 AM
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

14008


Many thanks

mancubus
07-27-2015, 07:47 AM
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
07-27-2015, 11:21 PM
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
07-28-2015, 02:08 AM
i would personally use a button. you can google with "excel vba insert button to sheet".


thanks google for saving me writing this. :D

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/short-cut-key-macros-excel.htm