Stuck again. extract data from cell between : &; mulitiple instances

[Ozzy_Bruce]

Hi guys, this has me stumped.
I am copying data from an online database that I am wanting to add to my own db, I can copy from the info from the online database and paste in to excel, all good. I have the next sheet pull the data from that paste with a simlpe =, but one of the copied cells includes a heap of data that I want to split in to new columns eg

(General) Status: Active; Secondary Colour: ; Size: Medium; Coat: Fleece; Grading: AL; Microchip: 953010001993799; Owner Note: Nicnak Labradooldes (Health) DNA Result: Clear; Hip Score: 5+7=12; Elbows: 0+0; PennHip: R .41 L .47;

Yes I am a dog breeder

And I would like to capture the data between the : & ; so the first instance would be "Active" then " " then "Fleece" then "AL" and so on. I have googled this to death but only find help on the first instance or data between spaces Etc.
Id love to put the formula in each cell to pull each result.

I am sure that I am going about this the hard way. Copying records from the online Db to Excel to then import in to my own Db. but its a lot faster then copy and paste each field.

Thanks for any help
Cheers Newby

Bruce

 

[Legacy 456155]

zoo import test.xlsm
I am curious if any of the formula geniuses can cook up something. In the mean time, I'll take a look at it and see what I can do.

 

[Legacy 456155]

This will parse the data, as is, into a new row. However, as mentioned, you will be required to add a semi-colon after blank fields. The parser could accommodate for blank fields if you will share which fields may possibly be blank. The code ignores the Owner Note field and assumes that it is always blank. If this is not the case, it will return offset results at times. Run GetRecord.

Function GetRecord()
    Dim ret(0, 28), i As Integer, GenInfo
   
    With Sheet1
   
        ret(0, 0) = .[F1]
        ret(0, 1) = .[F2]
        ret(0, 2) = .[F3]
        ret(0, 3) = .[F4]
        ret(0, 4) = .[F5]
        ret(0, 5) = .[F6]
        ret(0, 6) = .[B8]
        ret(0, 7) = .[B11]
        ret(0, 8) = .[F12]
        ret(0, 9) = .[G12]
        ret(0, 10) = .[F13]
        ret(0, 11) = .[G13]
        ret(0, 12) = .[A15]
        ret(0, 13) = .[A16]
        ret(0, 14) = .[A17]
        ret(0, 15) = .[E15]
        ret(0, 16) = .[E16]
        ret(0, 17) = .[E17]
       
        GenInfo = ParseGeneralInfo(.[A18])
       
        For i = 0 To 10
            ret(0, 18 + i) = GenInfo(i)
        Next
       
    End With
   
    Sheet3.Range("A1").End(xlDown).Offset(1).Resize(, 29) = ret
   
End Function

Private Function ParseGeneralInfo(Target As Range)
    Dim s() As String, i As Integer, ret(10) As String
  
    s = Split(Replace(Target, "Owner Note:", ""), ":")
  
    For i = 1 To UBound(s)
        ret(i - 1) = Split(s(i), ";")(0)
    Next
  
    ParseGeneralInfo = ret
End Function

 

[Ozzy_Bruce]

Looking great
Secondary colour and Given name are possibly the only 2 that might contain blank field.
(Health) DNA Result: is a heading and therefore should be between ;(Health) DNA Result: thats no big deal I can add the missing ;

Thanks
Bruce

 

[Ozzy_Bruce]

Just a little thing but its biting me.
when I paste a new set of data over the existing data on sheet 1, I get a "you carnt do that to a merged field" so I paste it to the right and then copy it from there and put the first cell on A1
Would you know a work around for this?

thanks loads

Bruce

 

[Legacy 456155]

Paste text if you have that option. Have you tried that?

 

[Peter_SSs]

If you wanted a formula approach to splitting up the text into the correct columns (I note that the data has 'Owner Note:' but your Sheet3 does not appear to have a column for that data) you could try this, copied across.

Note that
- I have placed headings in this sheet to help with the formula.
- I have altered the heading in column C to match the text that appears in your data.

20 10 17.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1		Status:	Secondary Colour:	Size:	Coat:	Grading:	Microchip	DNA Result:	Hip Score:	Elbows:	PennHip
2	(General) Status: Active; Secondary Colour: ; Size: Medium; Coat: Fleece; Grading: AL; Microchip: 953010001993799; Owner Note: Nicnak Labradooldes (Health); DNA Result: Clear; Hip Score: 5+7=12; Elbows: 0+0; PennHip: R .41 L .47;	Active		Medium	Fleece	AL	953010001993799	Clear	5+7=12	0+0	R .41 L .47
Extract

Cell Formulas
Range	Formula
B2:K2	B2	=TRIM(REPLACE(LEFT($A2,FIND(";",$A2,SEARCH(B$1,$A2))-1),1,SEARCH(B$1,$A2)+LEN(B$1),""))

 

[Legacy 456155]

Peter, does the formula approach require inserting the semi-colons if they are missing?

 

[Peter_SSs]

Peter, does the formula approach require inserting the semi-colons if they are missing?

It shouldn't. I did put in the missing semi-colon that was mentioned earlier but the formulas work without it for that sample data at least.
The formulas do require the colons to be in place.

@Ozzy_Bruce
Assuming that ..

1. Sheet1 can be set up as shown in my previous post
2. Every set of data actually has something in the 'Status:' section

.. then here is a way that you could use to get your results into Sheet3 on the next available row.

1. On Sheet3, 'Freeze Panes' below row 1 so the headings are always visible. You might also need to format the Microchip column as Text so that the long numbers do not get converted to scientific notation when transferred to this sheet.
2. Right click the sheet name tab on 'Sheet1' and choose "View Code".
3. Copy and Paste the code below into the main right hand pane that opens at step 2.
4. Paste your new data into cell A2 of 'Sheet1' & check/adjust colons and semi-colons if required.
5. Double-click cell A2 (Sheet1)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Address = "$A$2" Then
    Cancel = True
    Sheets("Sheet3").Cells(Rows.Count, "S").End(xlUp).Offset(1).Resize(, 10).Value = Target.Offset(, 1).Resize(, 10).Value
    Range("A2").Value = "Paste new data here"
    Application.Goto Reference:=Sheets("Sheet3").Cells(Rows.Count, "S").End(xlUp), Scroll:=True
  End If
End Sub

 

[Legacy 456155]

My attempt. Hypothetically, if the clipboard is loaded with data as you have described it, the only thing you should have to do is run sub GetRecord.
See zoo import test 2.xlsm in this folder. Copy your web data and click on the button.
Let me know if the code needs clarification.

Option Explicit

Sub TestLoadClipBoard()
    Sheets("Test").Range("A1:H18").Copy
End Sub

Public Sub GetRecord()
    Dim ret(0, 28), i As Integer, GenInfo
   
    Application.ScreenUpdating = False
    Application.Goto Sheets("Dump").Range("A1")
    ActiveSheet.Paste
   
    With ActiveSheet
   
        ret(0, 0) = .[F1]
        ret(0, 1) = .[F2]
        ret(0, 2) = .[F3]
        ret(0, 3) = .[F4]
        ret(0, 4) = .[F5]
        ret(0, 5) = .[F6]
        ret(0, 6) = .[B8]
        ret(0, 7) = .[B11]
        ret(0, 8) = .[F12]
        ret(0, 9) = .[G12]
        ret(0, 10) = .[F13]
        ret(0, 11) = .[G13]
        ret(0, 12) = .[A15]
        ret(0, 13) = .[A16]
        ret(0, 14) = .[A17]
        ret(0, 15) = .[E15]
        ret(0, 16) = .[E16]
        ret(0, 17) = .[E17]
       
        GenInfo = ParseGeneralInfo(.[A18])
       
        For i = 0 To 10
            ret(0, 18 + i) = GenInfo(i)
        Next
       
        .DrawingObjects.Delete
        .Cells.Clear
    End With
   
    With Worksheets("Results").Range("A1").End(xlDown).Offset(1).Resize(, 29)
        .Value = ret
        Application.Goto .Item(1), True
    End With
   
    Application.ScreenUpdating = True
End Sub

Private Function ParseGeneralInfo(Target As Range)
    Dim i As Integer, ret(10) As String, f As String, t As String
   
    t = Target
   
    For i = 0 To 10
        f = Choose(i + 1, "(General) Status:", "Secondary Colour:", "Size:", "Coat:", "Grading:", "Microchip:", "Owner Note:", "Nicnak Labradooldes (Health) DNA Result:", "Hip Score:", "Elbows:", "PennHip:")
        ret(i) = GetFieldValue(t, f)
    Next
  
    ParseGeneralInfo = ret
End Function

Private Function GetFieldValue(t As String, f As String) As String
    Dim s As String, i As Integer, c As String
    s = Split(t, f)(1)
    For i = 1 To Len(s)
        c = Mid(s, i, 1)
        If c = ";" Then
            GetFieldValue = Trim(Left(s, i - 1))
            Exit Function
        ElseIf c = ":" Then
            Exit Function
        End If
    Next
End Function

 

[Ozzy_Bruce]

Paste text if you have that option. Have you tried that?

Thaks but I only hve 2pasting options 1. Keep soure formatting. 2 Match destinatoin formatting. both return the same "we carn't do that to a merged cell"
If i un-merge A1 I can then paste in to sheet 1 with either option.

Thanks Bruce