Related
I am trying to print out "OK" value if the statements same value with "NumberPallete" but my code doesn't work right.
I have two conditions to compare from one cell value ["54# / 221"]. The first condition value for "SeriesNumber" is [88] and then the Second condition value for "NumberPallete" is [221#]. I am using looping for "SeriesNumber" and "NumberPallete" to find the value because I have long data in the table sheet.
and then from the different sheets using looping too, I am starting with the First condition checks "SeriesNumber" value if the value is right, then check the second condition from "NumberPallete" value, in this condition, I want a print out "ok" value but "ok" value doesn't print out.
I am sorry, my English is poor. I'm trying my best to explain. Please help me.
Dim NumberPallete As String
Dim SeriesNumber As String
Dim I As Long
Dim j As Long
Dim z As Long
i = Cells(Rows.Count, 15).End(xlUp).Row
For j = 6 To i
'Cells(j, 20).Value = Right(Cells(j, 15).Value, Len(Cells(j, 15)) - InStr(1, Cells(j, 15).Value, "/"))
SeriesNumber = Right(Cells(j, 15).Value, Len(Cells(j, 15)) - InStr(1, Cells(j, 15).Value, "/"))
'Cells(j, 21).Value = Left(Cells(j, 15).Value, Len(Cells(j, 15)) - InStr(1, Cells(j, 15).Value, "/"))
NumberPallete = Left(Cells(j, 15).Value, Len(Cells(j, 15)) - InStr(1, Cells(j, 15).Value, "/"))
If SeriesNumber = 221 Then
For z = 4 To 250
If Worksheets("AAA").Cells(z, 2).Value = NumberPallete Then
Worksheets("AAA").Cells(z, 6).Value = "OK"
End If
Next z
Else
MsgBox ("Not OK")
End If
Next j
I may not have fully understood what you are trying to do but the code below is doing something and, hopefully, it can be fixed to do what you want.
Sub FindPalletNumber()
' 062
' you can find code to enter 2 values with input boxes at this link:-
' https://stackoverflow.com/questions/62651211/vba-excel-search-in-excel-specific-word-and-delete-all-rows-who-does-not-have-t
Dim Snum As Integer ' serial number
Dim Pnum As Integer ' pallet number
Dim Txt As String ' message text
Snum = 221 ' number only
Pnum = 54 ' no # sign, no brackets
If MarkOK(Snum, Pnum) Then
Txt = "Found and marked."
Else
Txt = "No match found."
End If
MsgBox Txt, vbInformation, "Action report"
End Sub
Private Function MarkOK(Snum As Integer, _
Pnum As Integer) As Boolean
' 062
' return True if found and marked
Const Pallet As Long = 0 ' element of array Nums
Const Serial As Long = 1 ' element of array Nums
Dim Nums() As String ' split cell pattern "54# / 221"
Dim Done As Boolean ' True if found
Dim R As Long ' loop counter: Row in ActiveSheet
Dim R2 As Long ' loop counter: Row in Ws("AAA")
For R = 6 To Cells(Rows.Count, 15).End(xlUp).Row
Nums = Split(Cells(R, 15).Value, "/")
' Nums(Pallet) = "54# ", Nums(Serial) = " 221"
If Val(Nums(Serial)) = Snum Then
With Worksheets("AAA")
For R2 = 4 To .Cells(.Rows.Count, 2).End(xlUp).Row
If .Cells(R2, 2).Value = Trim(Nums(Pallet)) Then
.Cells(R2, 6).Value = "OK"
Done = True
Exit For
End If
Next R2
End With
End If
If Done Then Exit For ' stop search if found
Next R
MarkOK = Done
End Function
In the first procedure the Pallet and Serial numbers should be set (Pnum and Snum). Then, when you run that procedure, it will call the other one which reports back whether a match was found or not. I have added a link where you can find code to get the two values from Input boxes, if that is what you need.
The function looks for the serial number in the ActiveSheet. If found, it looks for the pallet number in Sheet("AAA"). This is confusing because it looks for the pallet number found in the ActiveSheet, not the pallet number specified in the search. The pallet number in the search specs ends up not being used at all. Perhaps it's not needed.
Anyway, when the pallet is found the row is marked and the search terminates. If the pallet number isn't found the loop in the ActiveSheet is continued to look for another instance of the serial number. Note that the code is not enabled to find multiple pallets with the same serial number.
A B C
1 numbers signs **Result**
2 *001* *alpha* 001-alpha
3 *001*111*221*104* *alpha*kappa*epislon*ETA* 001-alpha, 111-kappa, 221-epislon, 104-ETA
4 *001*085* *alpha*delta* 001-alpha, 085-delta
I'm trying to concatenate the values in columns A and B into the following format under the result section. Anything helps, thanks.
Formula solution
Using Textjoin and Filterxml function, of which Textjoin available in Office 365 or Excel 2019 and Filterxml available in Excel 2013 & later versions of Excel
In C2, array formula (confirm by pressing Ctrl+Shift+Enter) copied down :
=TEXTJOIN(", ",1,IFERROR(TEXT(FILTERXML("<a><b>"&SUBSTITUTE(A2,"*","</b><b>")&"</b></a>","//b"),"000")&FILTERXML("<a><b>"&SUBSTITUTE(B2,"*","</b><b>-")&"</b></a>","//b"),""))
I'm assuming this is doable with formulas but it might get unwieldy, so perhaps a UDF like this:
Public Function JoinNumbersAndSigns(ByVal numbersRng As Range, ByVal signsRng As Range) As String
Dim nums As String
nums = numbersRng.Cells(1).Value
nums = Mid$(nums, 2, Len(nums) - 2) ' remove leading and trailing *
Dim signs As String
signs = signsRng.Cells(1).Value
signs = Mid$(signs, 2, Len(signs) - 2) ' remove leading and trailing *
Dim tempNums As Variant
tempNums = Split(nums, "*")
Dim tempSigns As Variant
tempSigns = Split(signs, "*")
Dim i As Long
For i = LBound(tempNums) To UBound(tempNums)
Dim tempString As String
Dim sep As String
tempString = tempString & sep & tempNums(i) & "-" & tempSigns(i)
sep = ", "
Next i
JoinNumbersAndSigns = tempString
End Function
In Action:
The nums = Mid$(nums, 2, Len(nums) - 2) and similar line for signs could probably be made more robust, but should work given your current data.
Here's another approach using regular expressions ...
Option Explicit
Public Function Link(vNumbers As Range, vSigns As Range) As Variant
' ADD REFERENCE TO "Microsoft VBScript Regular Expressions 5.5"
Dim vRegEx As New RegExp
Dim vNumbersMatches As MatchCollection
Dim vSignsMatches As MatchCollection
Dim vCounter As Long
' The two parameters must only reference a single cell
If vNumbers.Cells.Count <> 1 Or vSigns.Cells.Count <> 1 Then
Link = CVErr(xlErrRef)
Exit Function
End If
' use regular expression to get the numbers
vRegEx.Pattern = "([0-9]+)"
vRegEx.Global = True
vRegEx.MultiLine = True
Set vNumbersMatches = vRegEx.Execute(vNumbers.Text)
' Use regular expression to get the signs
vRegEx.Pattern = "([^\*]+)"
vRegEx.Global = True
vRegEx.MultiLine = True
Set vSignsMatches = vRegEx.Execute(vSigns.Text)
' If the number of Numbers and Signs differs, then return an error
If vNumbersMatches.Count <> vSignsMatches.Count Then
Link = CVErr(xlErrValue)
Exit Function
End If
' Loop through the Numbers and Signs, appending each set
For vCounter = 0 To vNumbersMatches.Count - 1
Link = Link & vNumbersMatches.Item(vCounter) & "-" & vSignsMatches.Item(vCounter) & IIf(vCounter < vNumbersMatches.Count - 1, " ,", "")
Next
End Function
And the output ...
As long as there will always be a correlation between the number of elements in A & B this will work
Sub SplitandConcat()
' Declare working vars
Dim lRow As Long: lRow = 2
Dim sOutputString As String
Dim iWorkIndex As Integer
Dim CommaSpace As String
While ActiveSheet.Cells(lRow, 1) <> ""
CommaSpace = ""
'Split the incoming string on delimiter
arInput1 = Split(ActiveSheet.Cells(lRow, 1), "*")
arInput2 = Split(ActiveSheet.Cells(lRow, 2), "*")
' For each non blank item in the 1st array join the corresponding item int the second
For iWorkIndex = 0 To UBound(arInput1)
If arInput1(iWorkIndex) <> "" Then
ActiveSheet.Cells(lRow, 3) = ActiveSheet.Cells(lRow, 3) & CommaSpace & arInput1(iWorkIndex) & "-" & arInput2(iWorkIndex)
CommaSpace = ", "
End If
Next iWorkIndex
' check next row
lRow = lRow + 1
Wend
End Sub
I would like some direction/help on how to code a VBA-coded solution for my scenario, details follow. I am very comfortable with VBA coding - I am really looking for advise on how to approach the problem, not any specific solution.
My department bears the highly-enviable task of daily label-making. We receive a spreadsheet from Production that has a cell/cells of serial numbers to be printed (examples below). The numbers are often not contiguous, but the basic (human-generated) 'format' is the same (hyphens for ranges, commas for single numbers). The serial numbers in the example below are 6 digits, but often are different lengths, adding to the complexity. I am looking for feedback on how to ultimately parse the cell.text into a complete list of serial numbers that can be ultimately used as a source for our label printer's software.
Again, I think I have the ability to actually code this; I am asking how to approach parsing the cell.value(s), identifying spaces, commas, and hyphens as needed, and retrieving a list of serial numbers, in any usable format. I can SPLIT at commas, and I can code the range before and after a hyphen. How do I approach the 6 digit format, as well as the change to the first three characters (364-365, could be many).
EXAMPLE SPREADSHEET CELL.VALUE: "364701-703, 705, 706, 708-710, 365100-104, 121" is a request for 14 labels:
EXPECTED PARSED RESULT: 364701, 364702, 36703, 364705, 364706, 364708, 364709, 364710, 365100, 365101, 365102, 365013, 350104, 365121
It's just a matter of how you keep track of things.
Given your data, the following will output what you want. You will note I added a single serial number item as you only had ranges listed in your sample:
Option Explicit
Sub labelMaker()
Const sRequest As String = "364701-703, 705, 706, 708-710,364800, 365100-104, 121"
Dim V, W, X
Dim lFirstThree As Long, I As Long, J As Long
'Dim D As Dictionary 'early binding
Dim D As Object 'late binding
'Set D = New Dictionary 'early binding
Set D = CreateObject("Scripting.Dictionary") 'late binding
V = Split(Replace(sRequest, " ", ""), ",")
For Each W In V
X = Split(W, "-")
If Len(X(0)) = 6 Then lFirstThree = Left(X(0), 3) 'we start a new series
For I = Right(X(LBound(X)), 3) To Right(X(UBound(X)), 3)
D.Add lFirstThree & I, lFirstThree & I
Next I
Next W
'write the results to the worksheet
V = WorksheetFunction.Transpose(D.Keys)
With Cells(1, 1).Resize(D.Count) 'will be on active sheet
.EntireColumn.Clear
.Value = V
End With
End Sub
The above works only with six digit serial numbers, which is what you provided. I'm reasonably sure the variability can be coded for, but without knowing how they vary (which is the fixed part and which the variable part), it would be hard to provide a one-size fits all solution.
You might code it however you would and post that to https://codereview.stackexchange.com/ and then you could see how some other people might approach it.
I don't have any illuminating advice, so I'll just show you how I'd do it. The splitting is easy enough and you just have to keep track of the first three numbers for when they're missing.
Public Sub GenerateSerialNumbers(ByVal sNumbers As String)
Dim vaComma As Variant, vaHyph As Variant
Dim i As Long, j As Long
Dim lPrefix As Long, lStart As Long, lEnd As Long
Dim sInput As String
Dim dc As Scripting.Dictionary
Set dc = New Scripting.Dictionary
vaComma = Split(sNumbers, ",")
For i = LBound(vaComma) To UBound(vaComma)
sInput = Trim$(vaComma(i))
If InStr(1, sInput, "-") > 0 Then
vaHyph = Split(sInput, "-")
'If you get a full one, keep the first three
If Len(vaHyph(0)) = 6 Then lPrefix = Val(Left$(sInput, 3)) * 1000
'Add the prefix if needed
lStart = Val(vaHyph(0))
If lStart < 1000 Then lStart = lPrefix + lStart
lEnd = Val(vaHyph(1))
If lEnd < 1000 Then lEnd = lPrefix + lEnd
Else
If Len(sInput) = 6 Then lPrefix = Val(Left$(sInput, 3)) * 1000
lStart = Val(sInput)
If lStart < 1000 Then lStart = lPrefix + lStart
lEnd = lStart
End If
'Generate the list
For j = lStart To lEnd
dc.Add j, j
Next j
Next i
Sheet1.Range("a1").Resize(dc.Count, 1).Value = Application.Transpose(dc.Items)
End Sub
try this:
Function trlMyString(myString As String) As String
On Error GoTo trlMyStringError
Dim i As Integer
Dim j As Integer
Dim helpArray() As String
Dim strg As String
Dim label1 As String
Dim label2 As String
strg = ""
helpArray() = Split(myString, ", ")
For i = LBound(helpArray) To UBound(helpArray)
If Len(helpArray(i)) > 3 And InStr(1, helpArray(i), "-") <> 4 Then
label1 = Left$(helpArray(i), 3)
helpArray(i) = Right$(helpArray(i), Len(helpArray(i)) - 3)
End If
If InStr(1, helpArray(i), "-") > 0 Then
For j = CInt(Left$(helpArray(i), 3)) To CInt(Right$(helpArray(i), 3))
'Debug.Print CInt(Left$(helpArray(i), 3)), CInt(Right$(helpArray(i), 3))
label2 = Trim$(Str$(j))
strg = strg & label1 & label2 & ", "
Next j
Else
label2 = helpArray(i)
strg = strg & label1 & label2 & ", "
End If
Next i
'Debug.Print strg
trlMyStringExit:
trlMyString = strg
Exit Function
trlMyStringError:
Resume trlMyStringExit
End Function
I am trying to split the following data (using VBA)
An example of the text I have is below
Scott Hamilton 1/2
I would like to display it like this on the same line
A15 Scott Hamilton
B15 1
C15 2
The cell always contains a name (first and last) and then there stats ie 1 of 2
I would like to split as above
Hope someone can help - Have attached a picture of some of my data (as this will have other text already on the sheet which I cannot move/change)
http://i40.tinypic.com/riyq9x.jpg
Edit:
Sorry forgot to add my attempt;
Sub SplitName()
Dim SplitName() As String
SplitName = Split(ActiveSheet.Cells(15, 1).Value)
Cells(15, 1) = SplitName(0) + " " + SplitName(1)
Cells(15, 2) = SplitName(2)
Cells(15, 3) = SplitName(3)
End Sub
I think first you need to split string before you find number. So first you need to get string occuring before number. In your case you split string before number occurs.
So you will get 2 strings as
Scott Hamilton and 1/2
Then split remaining string with seperator as "/"
So try like below
Dim str As String
Dim i As Integer
Dim strArray() As String
str = ActiveCell.Value
For i = 1 To Len(str)
If IsNumeric(Mid(str, i, 1)) Then
LeftString = Left(str, i – 1)
RightString = Right(str, Len(str) – i + 1)
Exit For
End If
Next i
Now split RightString with "/"
So do below
strArray = Split(RightString , "/")
This will seperate text 1/2
Hope you got the idea. I haven't tested this code. This is just idea which should work.
One way...
Sub tgr()
Dim rngFound As Range
Dim strFraction As String
Set rngFound = Columns("A").Find("/", , xlValues, xlPart)
If Not rngFound Is Nothing Then
Do
strFraction = Trim(Right(Replace(WorksheetFunction.Trim(rngFound.Text), " ", String(99, " ")), 99))
rngFound.Resize(, 3).Value = Array(Trim(Replace(rngFound.Text, strFraction, "")), _
Split(strFraction, "/")(0), _
Split(strFraction, "/")(1))
Set rngFound = Columns("A").Find("/", rngFound, xlValues, xlPart)
Loop While Not rngFound Is Nothing
End If
End Sub
You have a good start, but here are a few suggestions:
1. You might name your string as something different than the subroutine. Naming both as splitname is bad practice here.
2. Using the split function without stating a delimiter means split does its work based on a space (" "), so it will not split 1/2 into 1 and 2.
3. You say you would like to display on the same line, but in row A, B, C. If you want displayed in seperate rows, the first portion of cells should change, not the second portion.
Sub SplitName()
Dim Cell As Range, LastSpace As Long
Set Cell = ActiveSheet.Cells(15, 1)
LastSpace = InStrRev(Cell.Text, " ")
Cell.Offset(, 1).Resize(, 2).Value = Split(Mid(Cell.Text, LastSpace + 1), "/")
Cell.Value = Left(Cell.Text, LastSpace - 1)
End Sub
This is solution for cell A15, I assume you can generalize operation.
jQuery( window ).load(function() {
jQuery("#FullNametest").change(function(){
var temp = jQuery(this).val();
var fullname = temp.split(" ");
var firsname='';
var middlename='';
var lastname = '';
firstname=fullname[0];
lastname=fullname[fullname.length-1];
for(var i=1; i < fullname.length-1; i++)
{
middlename = middlename +" "+ fullname[i];
}
jQuery('#FirstName').val(firstname);
jQuery('#middlename').val(middlename);
jQuery('#LastName').val(lastname);
});
});
I am hoping someone could help me out with a VBA Excel macro.
I have received a worksheet in Excel 2007 which contains product names in one column, and I need to sort this into a logical format so I can use it. However, the list itself is not in any kind of logical order, is 10 000 rows long and I am going to have to do this every month!!
Basically, what I would like to do is search for certain keywords which are common to most of the entries and move them into separate cells in different columns (but in the same row as the original entry).
Regarding keywords: There are 3 different types, two of which I have a complete list of.
Example of keywords: some are measures such as cm (centimetre), mm (millimetre), m (metre) etc.). Then there are other keywords such as % and finally a last set of keywords which is wood, plastic, glass etc.
If this was not complicated enough, the measures (cm for example) are duplicated in some instances and are important details so I cant just separate them but would ideally like them in two adjacent cells.
Fortunately, there is a space after each measure, % sign and item material.
Working from right to left is the easiest way I can think of achieving this as the first description in the string varies wildly between entries and that can stay as is.
So, below is an example string, lets say this is in Cell A1. (Inverted commas are not included in the string and the word "by" appears in only about 100 cases. Usually it is missing...)
"Chair Leg Wood 100% 1m by 20cm"
I would ideally like for the string to be split up into cells as follows
Cell B1 - Chair Leg
Cell C1 - Wood
Cell D1 - 1m
Cell E1 - 2cm
Cell F1 - 100%
Having the % measures in the same column would be extremely helpful
Can anyone please help me with this or the beginnings of a macro which does this and then moves down the list - I have tried using some basic "find" and "len" formulas but really am at my wits end on how to deal with this!
The task boils down to defining a robust definition of the structure of the input data.
Form the info provided a candidate definition might be
<Description, one or more words> <Material, one word> <A value followd by %> <Dimension A> <optional "by"> <Dimension B>
The following macro will process data that conforms this this spec. The definition may need
expanding, eg two word materials (eg Mild Steel)
You will need to add error handling in case any rows don't conform, eg no % in the string, or % character elsewhere in string
Option Explicit
Dim dat As Variant
Sub ProcessData()
Dim r As Range
Dim i As Long
Set r = Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns(1)).Resize(, 5)
dat = r
For i = 1 To UBound(dat, 1)
ParseRow i, CStr(dat(i, 1))
Next
r = dat
ActiveSheet.Columns(5).Style = "Percent"
End Sub
Sub ParseRow(rw As Long, s As String)
'Chair Leg Wood 100% 1m by 20cm
Dim i As Long
Dim sDim As String, sPCnt As String, sMat As String, sDesc As String
Dim sA As String, sB As String
i = InStr(s, "% ")
sDim = Trim(Replace(Mid(s, i + 2), " by ", " ")) ' text to right of %, remove "by"
sA = Trim(Left(sDim, InStr(sDim, " "))) ' split dimension string in two
sB = Trim(Mid(sDim, InStr(sDim, " ")))
s = Left(s, i)
i = InStrRev(s, " ")
sPCnt = Mid(s, i + 1) ' text back to first space before %
s = Trim(Left(s, i))
i = InStrRev(s, " ") ' last word in string
sMat = Mid(s, i + 1)
sDesc = Trim(Left(s, i)) ' whats left
dat(rw, 1) = sDesc
dat(rw, 2) = sMat
dat(rw, 3) = sA
dat(rw, 4) = sB
dat(rw, 5) = sPCnt
End Sub
First, I'd use the Split function to separate the parts into an array, this will avoid most of the string functions and string math:
Dim parts As Variant
parts = Split(A1)
Then, I'd do my comparisons to each part.
Finally, I'd concatenate the parts I didn't breakout, and place all parts on the sheet.
This is based on your example which has spaces inbetween every part, though something similar could work otherwise, you just have to do more work with each part.
Here's my stab at it. We could use about 10 more examples, but this should be a start. To use, select a one column range with your descriptions and run SplitProduct. It will split it out to the right of each cell.
Sub SplitProducts()
Dim rCell As Range
Dim vaSplit As Variant
Dim i As Long
Dim aOutput() As Variant
Dim lCnt As Long
Const lCOLDESC As Long = 1
Const lCOLMAT As Long = 2
Const lCOLPCT As Long = 3
Const lCOLREM As Long = 4
If TypeName(Selection) = "Range" Then
If Selection.Columns.Count = 1 Then
For Each rCell In Selection.Cells
'split into words
vaSplit = Split(rCell.Value, Space(1))
ReDim aOutput(1 To 1, 1 To 1)
'loop through the words
For i = LBound(vaSplit) To UBound(vaSplit)
Select Case True
Case IsPercent(vaSplit(i))
'percents always go in the same column
lCnt = lCOLPCT
If UBound(aOutput, 2) < lCnt Then
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
End If
aOutput(1, lCnt) = vaSplit(i)
Case IsInList(vaSplit(i))
'list items always go in the same column
lCnt = lCOLMAT
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
If UBound(aOutput, 2) < lCnt Then
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
End If
aOutput(1, lCnt) = vaSplit(i)
Case IsMeasure(vaSplit(i))
'measurements go in the last column(s)
If UBound(aOutput, 2) < lCOLREM Then
lCnt = lCOLREM
Else
lCnt = UBound(aOutput, 2) + 1
End If
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
aOutput(1, lCnt) = vaSplit(i)
Case Else
'everything else gets concatentated in the desc column
aOutput(1, lCOLDESC) = aOutput(1, lCOLDESC) & " " & vaSplit(i)
End Select
Next i
'remove any extraneous spaces
aOutput(1, lCOLDESC) = Trim(aOutput(1, lCOLDESC))
'write the values to the left of the input range
rCell.Offset(0, 1).Resize(1, UBound(aOutput, 2)).Value = aOutput
Next rCell
Else
MsgBox "Select a one column range"
End If
End If
End Sub
Function IsPercent(ByVal sInput As String) As Boolean
IsPercent = Right$(sInput, 1) = "%"
End Function
Function IsInList(ByVal sInput As String) As Boolean
Dim vaList As Variant
Dim vaTest As Variant
'add list items as needed
vaList = Array("Wood", "Glass", "Plastic")
vaTest = Filter(vaList, sInput)
IsInList = UBound(vaTest) > -1
End Function
Function IsMeasure(ByVal sInput As String) As Boolean
Dim vaMeas As Variant
Dim i As Long
'add measurements as needed
vaMeas = Array("mm", "cm", "m")
For i = LBound(vaMeas) To UBound(vaMeas)
'any number of characters that end in a number and a measurement
If sInput Like "*#" & vaMeas(i) Then
IsMeasure = True
Exit For
End If
Next i
End Function
No guarantees that this will be speedy on 10k rows.