Separating Drug Data Matrix Information

[bobili]

In the list I want to create, my aim is to read the QR codes of the drugs and quickly separate the 4 information they contain. While I can do this for a single drug name as in the example, I cannot do this with the QR codes created by different drugs and different manufacturers. This is because the serial number and lot number fields are of variable length and the start of the application identifier number and the end of the previous value contain the same value, or the end of the value begins with the application identifier number. I would be glad if you can help with this.

Sub Düğme1_Tıklat()
son = Range("a65536").End(3).Row
For a = 2 To son
b = Mid(Cells(a, 1), 4, 13)
Cells(a, 2) = b
Next a
son = Range("a65536").End(3).Row
For a = 2 To son
b = Mid(Cells(a, 1), 19, 14)
Cells(a, 3) = b
Next a
son = Range("a65536").End(3).Row
For a = 2 To son
b = Mid(Cells(a, 1), 35, 6)
Cells(a, 4) = b
Next a
son = Range("a65536").End(3).Row
For a = 2 To son
b = Mid(Cells(a, 1), 43, 11)
Cells(a, 5) = b
Next a
End Sub

 

[Peter_SSs]

Welcome to the MrExcel board!

One example is not much to go on so if the following does not meet your needs could we have some more please (with results)?
Also, very hard to copy those details from a picture, so please investigate this:

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Test this with a copy of your data.
I have assumed (from your one example) that the first 3 values will be all numerical and the 4th value could include text.

Sub SplitVals()
  Dim RX As Object
  Dim a As Variant
  Dim i As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Pattern = "^(010)(\d{13})(21)(\d{1,23})(17)(\d{6})(10)(.{1,22})$"
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      If RX.Test(a(i, 1)) Then
        a(i, 1) = RX.Replace(a(i, 1), "$2;$4;$6;$8")
      Else
        a(i, 1) = vbNullString
      End If
    Next i
    With .Offset(, 1)
      .Value = a
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2))
      .Resize(, 4).Columns.AutoFit
    End With
  End With
End Sub

Here are my sample data and results

bobili.xlsm
	A	B	C	D	E
1
2	010869952209694721251000013754231724013110A1161007	8699522096947	25100001375423	240131	A1161007
3	10236598456325634A
4
5	0108699522096947212514231724013110A116100856985654458	8699522096947	251423	240131	A116100856985654458
Sheet1

 

[bobili]

Welcome to the MrExcel board!

One example is not much to go on so if the following does not meet your needs could we have some more please (with results)?
Also, very hard to copy those details from a picture, so please investigate this:

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Test this with a copy of your data.
I have assumed (from your one example) that the first 3 values will be all numerical and the 4th value could include text.

Sub SplitVals()
  Dim RX As Object
  Dim a As Variant
  Dim i As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Pattern = "^(010)(\d{13})(21)(\d{1,23})(17)(\d{6})(10)(.{1,22})$"
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      If RX.Test(a(i, 1)) Then
        a(i, 1) = RX.Replace(a(i, 1), "$2;$4;$6;$8")
      Else
        a(i, 1) = vbNullString
      End If
    Next i
    With .Offset(, 1)
      .Value = a
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2))
      .Resize(, 4).Columns.AutoFit
    End With
  End With
End Sub

Here are my sample data and results

bobili.xlsm
	A	B	C	D	E
1
2	010869952209694721251000013754231724013110A1161007	8699522096947	25100001375423	240131	A1161007
3	10236598456325634A
4
5	0108699522096947212514231724013110A116100856985654458	8699522096947	251423	240131	A116100856985654458
Sheet1

Thank you, I will learn more with your reply

 

[bobili]

The problem I'm facing here is that some field values have different lengths.

 

[bobili]

sabit uzunlukta olmayan değer alanları farklı karakterler, metinler veya sayılar içerebilir

non-fixed-length value fields can contain different characters, text or numbers

 

[Peter_SSs]

So, as I said before, if my suggestion does not meet your needs, give us some more sample data with the expected results with XL2BB.
Say 6 or 8 rows with data that shows the sort of variation that can occur.

 

[Peter_SSs]

non-fixed-length value fields can contain different characters, text or numbers

Try this then

Sub SplitVals_v2()
  Dim RX As Object
  Dim a As Variant
  Dim i As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Pattern = "^(010)(\d{13})(21)(.{1,23})(17)(\d{6})(10)(.{1,22})$"
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      If RX.Test(a(i, 1)) Then
        a(i, 1) = RX.Replace(a(i, 1), "$2;$4;$6;$8")
      Else
        a(i, 1) = vbNullString
      End If
    Next i
    With .Offset(, 1)
      .Value = a
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2))
      .Resize(, 4).Columns.AutoFit
    End With
  End With
End Sub

bobili.xlsm
	A	B	C	D	E
1
2	010869952209694721251000013754231724013110A1161007	8699522096947	25100001375423	240131	A1161007
3	10236598456325634A
4
5	010869952209694721x5Ay4231724013110A1161abc569856XX44EE	8699522096947	x5Ay423	240131	A1161abc569856XX44EE
Sheet1

 

[bobili]

thank you it was exactly what i wanted ?

 

[Peter_SSs]

You're welcome. Glad it worked for you. Thanks for letting us know.

Might need to change the 'Mark as solution' post now though?