There is no underline in the actual string.
The string always starts with the number and the third number always has # or LB at the end of the number which I want to use.
Option Explicit
Sub Demo()
Dim Rg As Range
Dim T As String, TT As String, L As String
Dim I As Integer
Dim Flg As Boolean
For Each Rg In Range("A1:A" & Cells(Rows.Count, "A").End(3).Row)
If (Rg <> "") Then
Rg.Replace "(*)", ""
T = Rg: Flg = False: TT = ""
For I = 1 To Len(T)
L = Mid(T, I, 1)
If ((Asc(L) >= 48) And (Asc(L) <= 57)) Then
TT = TT & L: Flg = True
Else
If Flg Then TT = TT & " ": Flg = False
End If
Next I
Rg = Split(TT, " ")(0) & ". " & Split(TT, " ")(1) & "x" & Split(TT, " ")(2) & "x" & Split(TT, " ")(3)
End If
Next Rg
End Sub
This is great, but its kinda complicated for me to understand to modify for my need (I would want the fixes to be done in some other column and not column A itself, i.e. after the code works I want column lets say G to have 12*14*21 not in column A itself).
The file was really welcome ...!
Ajust DstCol to your need
Pay attention to row 926
Option Explicit
Sub Demo()
Const DstCol = "D"
Dim Rg As Range
Dim T As String, TT As String, L As String
Dim I As Integer
Dim Flg As Boolean
Columns("A").Copy Destination:=Cells(1, DstCol)
For Each Rg In Range(Cells(2, DstCol), Cells(Rows.Count, DstCol).End(3))
If (Rg <> "") Then
Rg.Replace "(*)", ""
T = Rg: Flg = False: TT = ""
For I = 1 To Len(T)
L = Mid(T, I, 1)
If ((Asc(L) >= 48) And (Asc(L) <= 57)) Then
TT = TT & L: Flg = True
Else
If Flg Then TT = TT & " ": Flg = False
End If
Next I
Rg = Split(TT, " ")(0) & "x" & Split(TT, " ")(1) & "x" & Split(TT, " ")(2)
End If
Next Rg
End Sub
It would be better if I had 15 in one column, 18 in another column and 21 in another column for me to then multiply it
I have to multiply 15x18x21
Here's how I read your problem.
Extract numbers:
1) From the beginning
2) preceded by an X
3) followed by LB or #
So, for example
row 87
12 X 18 SCALE PAPER (17 LBS/BDL)
The code extracts 12, 18 & 17
If any problem, post back with your desired result.
Sub test()
Dim a, i As Long, m As Object, ii As Long
With Range("a2", Range("a" & Rows.Count).End(xlUp))
a = .Value
ReDim Preserve a(1 To UBound(a, 1), 1 To 3)
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(^|X *)(\d+)|(\d+)(?= *(LB|#))"
For i = 1 To UBound(a, 1)
Set m = .Execute(a(i, 1))
If m.Count > 1 Then
For ii = 0 To 2
a(i, ii + 1) = m(ii).submatches(1) & m(ii).submatches(2)
Next
End If
Next
End With
.Columns(2).Resize(, 3).Value = a
End With
End Sub
Suppose my column is now in F instead of A and I want the results to be pasted from Column Q, so Q, R and S.
How do I modify your code?
I am a beginner with VBA, so everything is complex for me.
Last edited by jeffreybrown; 03-17-2020 at 12:48 PM.
Reason: Please do not use full quotes!
You refer to try
I am learning VBA. Therefore, Code has many problems. Please ignore it
PHP Code:
Function My_Product(ByVal Text As String, Choise As Boolean) Dim i As Integer, n As Long Dim strTemp As String, Str, eText As String Text = Split(Text, "(")(0) Text = Replace(Text, "#", "") Text = Replace(Text, "X", " ") Text = Replace(Text, " ", "*") Text = Replace(Text, "/", "*") For i = 1 To Len(Text) Select Case Asc(Mid(Text, i, 1)) Case 40 To 57, 94 strTemp = strTemp & Mid(Text, i, 1) End Select Next i For Each Str In Split(strTemp, "*") If Str <> "" Then If n = 3 Then Exit For If Not IsNumeric(Str) Then Str = Val(StrReverse(Str)): Str = StrReverse(Val(Str)) If Str = 0 Then GoTo 1 End If eText = IIf(eText = "", Str, eText & "*" & Str) n = n + 1 End If 1: Next If n > 2 Then If Choise = False Then My_Product = eText Else My_Product = Evaluate(eText) End If End Function
Last edited by NhatChiLan; 03-17-2020 at 12:14 AM.
You may give this a try to see if this covers all your strings and find the measurements correctly.
In the attached click the button called "Find Measurements & Calculate" to run the code.
Sub FindMeasurements()
Dim Matches As Object
Dim x As Variant
Dim y As Variant
Dim i As Long
Dim j As Long
Dim m1 As Long
Dim m2 As Long
Dim m3 As Long
Application.ScreenUpdating = False
x = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
ReDim y(1 To UBound(x, 1), 1 To 4)
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(\d+) ?X ?(\d+).*?(\d+) ?(LB|#)"
For i = 1 To UBound(x, 1)
If .test(x(i, 1)) Then
Set Matches = .Execute(x(i, 1))
m1 = Matches(0).submatches(0)
m2 = Matches(0).submatches(1)
m3 = Matches(0).submatches(2)
y(i, 1) = m1
y(i, 2) = m2
y(i, 3) = m3
y(i, 4) = m1 * m2 * m3
End If
Next i
End With
Range("B2").Resize(UBound(y, 1), 4).Value = y
Application.ScreenUpdating = True
End Sub
Regards sktneer
Treat people the way you want to be treated. Talk to people the way you want to be talked to. Respect is earned NOT given.
Sub zz()
Dim a, k, s$
a = Range("a1:a" & [a1048576].End(3).Row)
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "((?:.*-)\d+|\d+)\D+(\d+)\D+(\d+).*"
For i = 2 To UBound(a)
If .test(a(i, 1)) Then
k = Split(.Replace(a(i, 1), "$1*$2*$3"), "-")
s = k(UBound(k))
a(i, 1) = s & " = " & Evaluate(s)
End If
Next
End With
[c1].Resize(i - 1) = a
End Sub
Sub test()
Dim a, i As Long, m As Object, ii As Long
With Range("f2", Range("f" & Rows.Count).End(xlUp)) '<-- this is column(1)
a = .Value
ReDim Preserve a(1 To UBound(a, 1), 1 To 3)
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(^|X *)((\d+)( *- *\d+)?)|(\d+)(?= *(LB|#))"
For i = 1 To UBound(a, 1)
Set m = .Execute(a(i, 1))
If m.Count > 1 Then
For ii = 0 To 2
a(i, ii + 1) = m(ii).submatches(1) & m(ii).submatches(4)
Next
End If
Next
End With
.Columns(12).Resize(, 3).Value = a '<-- 12th clumn from data column
.Columns(15).FormulaR1C1 = "=product(rc[-3]:rc[-1])"
End With
End Sub
I have the same requirement but for a different set of strings, I need to pick the numbers between 2 Xs and the string has HOT sometimes and sometimes it doesn't, but prime need is to pick the numbers before and after the Xs:
Strings can be like:
10.5X2X4.5 WIND.BAG PRT.2COL .WIND.1/2 FRONT/1/2 GOSSET (1M)
11 X 3 X 16 PIZZA BAGS PRINTED (500/B0X)
11X4X16 BROWN BREAD BAG PRINTED (1000/BOX)
340113-4.5" X 1.88" X 16.625" SUB PLAIN BAG (1000/BOX)
4 3/4 X 3 X 10 BAGS GP PRT. AROUCH V BOTTOM (1000/BOX)
5 1/4 X 3 1/2 X 12 BAR-B-Q BAGS (500/B0X
5.75X13.5X4.5 BROWN WAX BAG PRT.MEUNERIE URBAINE(1M/BOX0
6X3/4X63/4 SAC SANDWICH CIRE (1M/BOX)
8.75"X 2"X11" WHITE PIZZA BAG PRT. (1M)
7.5" X 2" X 8" FOIL HAMBURGER BAG (1000/BOX)
FOIL HAMBURGER BAGS 6X3/4X6.5 (1M/BOX)
FOIL HOT DOG 7X1.5X5.5 (1000/BOX)
FOIL HOT DOG BAG 7X1.5X5.5 (1000/BOX)
MANCHON HOT DOG GENERIQUE 3.5X1,25X7,5(1000/BOX)
POLYBAGS .002; 9x12
Seperate the numbers betweens the Xs and put in a different columns and then use formaula =product(rc[-3]:rc[-1]/432)
Please don't quote whole posts -- it's just clutter.*If you are responding to a post out of sequence, limit quoted content to a few relevant lines that makes clear to whom and what you are responding.
Bookmarks