Is there a clean and tidy way to get cells split ONLY by sheet name? I have a bunch of cells that look something like this.
=(Xlookup($A2,Staff!A:A,Client!K:K)*E2
=B3*(Xlookup(E3,Auto!1:1,Desc!3:3)
And, all kinds of other stuff. Basically, I am trying to parse out only the sheet names from each cell. Each sheet name ends with a '!' character. So, I am trying to split one cell into multiple columns, based on the '!' character, and ignore any text that is not a sheet name. I tested the script below, but all it does is a basic split from one cell into multiple columns, which includes the sheet name, but all kinds of superfluous text, which I don't want.
Sub SplitData()
Const SrcCol = 1 ' A
Const TrgCol = 2 ' B
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim TheVal As String
Dim TheArr As Variant
Dim Num As Long
Application.ScreenUpdating = False
TrgRow = 1
LastRow = Cells(Rows.Count, SrcCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
TheVal = Cells(SrcRow, SrcCol).Value
TheArr = Split(TheVal, ",")
Num = UBound(TheArr) + 1
Cells(TrgRow, TrgCol).Resize(ColumnSize:=Num).Value = TheArr
TrgRow = TrgRow + 1
Next SrcRow
Application.ScreenUpdating = True
End Sub
Now:
Desired:
If you have O365, this will work for you ...
=LET(x, TRANSPOSE(FILTERXML("<d><r>" & SUBSTITUTE(A1, ",", "</r><r>") & "</r></d>", "//r[contains(text(),""!"")]")), MID(x, 1, FIND("!", x)))
... here's hoping you do, a lot easier.
Alternatively, I created my own VBA routine with the assumption that everything to the right of the formula is free to load into, just adjust for errors, names, performance, etc. as required ...
Public Sub GetWorksheets()
Dim lngRow As Long, lngColumn As Long, strFormula As String
Dim arrFormula() As String, i As Long, arrSubFormula() As String
With Sheet1
For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
strFormula = Trim(.Cells(lngRow, 1))
lngColumn = 2
If strFormula <> "" Then
arrFormula = Split(strFormula, "!")
For i = 0 To UBound(arrFormula) - 1
arrSubFormula = Split(arrFormula(i), ",")
strFormula = arrSubFormula(UBound(arrSubFormula)) & "!"
.Cells(lngRow, lngColumn) = strFormula
lngColumn = lngColumn + 1
Next
End If
Next
End With
End Sub
Related
I need to contactinate data of two columns from two different worksheets using vba macro.
Ex- in an excel sheet there are two tabs/worksheets sheet1 and sheet2. sheet1 is having column firstname & middlename, sheet2 is having column last name. I want to concat all first,middle & last name .
i am able to concat column which are present in same worksheet but not the column from different worksheets. Kindly suggest.
Thanks.
As you wanted a VBA solution, I've put something together for you. It checks if the number of rows in columns A in the two sheets are the same, loads the data from columns A/B in the first sheet and column A in the second sheet into an array, and then loops these arrays, concatenating then with spaces between using Trim to cater for missing values and writing this to the column B of the second sheet:
Sub sConcatenate()
Dim wsFName As Worksheet
Dim wsLName As Worksheet
Dim wsOutput As Worksheet
Dim lngLastRow As Long
Dim lngLoop1 As Long
Dim aFName() As Variant
Dim aMName() As Variant
Dim aLName() As Variant
Set wsFName = ThisWorkbook.Worksheets("FName")
Set wsLName = ThisWorkbook.Worksheets("LName")
Set wsOutput = ThisWorkbook.Worksheets("LName")
lngLastRow = wsFName.Cells(wsFName.Rows.Count, "A").End(xlUp).Row
If lngLastRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row Then
aFName = wsFName.Range("A1:A" & lngLastRow).Value
aMName = wsFName.Range("B1:B" & lngLastRow).Value
aLName = wsLName.Range("A1:A" & lngLastRow).Value
For lngLoop1 = LBound(aFName, 1) To UBound(aFName, 1)
wsOutput.Cells(lngLoop1, 2) = Trim(Trim(aFName(lngLoop1, 1) & " " & aMName(lngLoop1, 1)) & " " & aLName(lngLoop1, 1))
Next lngLoop1
End If
Set wsFName = Nothing
Set wsLName = Nothing
Set wsOutput = Nothing
End Sub
Regards,
Why don't you just use the CONCATENATE function? Open both workbooks and in the destination cell write the CONCATENATE function with the directions.
=CONCATENATE(Cell from Workbook 1," ",Cell from Workbook 2)
You didn't mention the details of your use case. But if you want something programatic, the code below shows how you can reference different workbooks and worksheets. You can a for loop and modify it for your use case.
Sub conc()
Dim destination_Wb as Workbook, wb1 As Workbook, wb2 As Workbook
Dim destination_Ws as Worksheet, ws1 As Worksheet, ws2 As Worksheet
Set destination_Wb = Workbooks(“Destination Workbook.xlsm”)
...
...
Set destination_Ws = destination_Wb.Sheets("Sheet1")
...
...
destination_Ws.Cells(1, 1).Value = ws1.Cells(1, 1).Value + " " + ws2.Cells(1, 1).Value
End sub
Concatenate Columns
Adjust the values in the constants section.
The Code
Option Explicit
Sub ConcatNames()
Const Source As String = "Sheet1"
Const Target As String = "Sheet2"
Const NameColumn As Long = 1
Const MiddleNameColumn As Long = 2
Const LastNameColumn As Long = 1
Const FullNameColumn As Long = 2
Const FirstRow As Long = 2
Dim rng As Range
Dim vName, vMiddle, vLast, vFull
Dim RowsCount As Long, i As Long
Dim CurrString As String
With ThisWorkbook.Worksheets(Source)
Set rng = .Columns(NameColumn).Find(What:="*", _
LookIn:=xlFormulas, SearchDirection:=xlPrevious)
Set rng = .Range(.Cells(FirstRow, NameColumn), rng)
vName = rng
RowsCount = rng.Rows.Count
Set rng = .Cells(FirstRow, MiddleNameColumn).Resize(RowsCount)
vMiddle = rng
End With
With ThisWorkbook.Worksheets(Target)
Set rng = .Cells(FirstRow, LastNameColumn).Resize(RowsCount)
vLast = rng
End With
ReDim vFull(1 To RowsCount, 1 To 1)
For i = 1 To RowsCount
GoSub BuildString
Next i
With ThisWorkbook.Worksheets(Target)
Set rng = .Cells(FirstRow, FullNameColumn).Resize(RowsCount)
rng = vFull
End With
Exit Sub
BuildString:
If vName(i, 1) = "" Then Return
CurrString = vName(i, 1)
If vMiddle(i, 1) <> "" Then CurrString = CurrString & " " & vMiddle(i, 1)
If vLast(i, 1) <> "" Then CurrString = CurrString & " " & vLast(i, 1)
vFull(i, 1) = WorksheetFunction.Trim(CurrString)
Return
End Sub
The IDs column in the first table contains multiple values in each cell that needs to be split. However, the unique issue is to retain both [name] and [description] info by ID into a new table.
.
The following VBA code performs the transpose paste option. This is what I am starting with to split cells with Chr(10), or new line as the delimiter:
Sub splitText()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals
End Sub
Other than this, I am still searching for ideas.
Maybe this will help:
Sub splitText()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim lngRow As Long, lngEl As Long
With Sheet2
'Range A2:A5
For lngRow = 5 To 2 Step -1
splitVals = Split(.Range("A" & lngRow).Value, Chr(10))
'the first value
.Range("A" & lngRow).Value = splitVals(0)
'remaining values
For lngEl = 1 To UBound(splitVals)
.Rows(lngRow + lngEl).Insert
.Range("A" & lngRow + lngEl).Value = splitVals(lngEl)
.Range("B" & lngRow + lngEl & ":C" & lngRow + lngEl).Value = .Range("B" & lngRow & ":C" & lngRow).Value
Next lngEl
Next lngRow
End With
End Sub
Change Sheet Code/Name and Range as necessary.
Before:
After:
It's a bit more involved than your solution because you have to insert the correct number of rows below the targeted cell and then copy the IDs and the other data into the new rows. Here's an example to help you along.
There's a little "trickery" I'm using when I calculate the offset value. I'm doing this because you can assume that all arrays from the Split function will begin indexing at 0, but my personal habit is to write code that can work with either a 0 or 1 lower bound. Calculating and using an offset makes it all work for the loops and indexes.
Option Explicit
Sub test()
SplitText ActiveCell
End Sub
Sub SplitText(ByRef idCell As Range)
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(idCell.Value, Chr(10))
If LBound(splitVals) = -1 Then
'--- the split character wasn't found, so exit
Exit Sub
End If
Dim offset As Long
offset = IIf(LBound(splitVals) = 0, 1, 0)
totalVals = UBound(splitVals) + offset
Dim idSheet As Worksheet
Set idSheet = idCell.Parent
Dim idRow As Long
idRow = idCell.Row
'--- insert the number of rows BELOW the idCell to hold all
' the split values
Dim i As Long
For i = 1 To totalVals - 1
idSheet.Rows(idRow + 1).Insert
Next i
'--- now add the IDs to all the rows and copy the other columns down
Const TOTAL_COLUMNS As Long = 3
Dim j As Long
Dim startIndex As Long
startIndex = LBound(splitVals) + offset
For i = startIndex To totalVals
idCell.Cells(i, 1) = splitVals(i - offset)
For j = 2 To TOTAL_COLUMNS
idCell.Cells(i, j) = idCell.Cells(1, j)
Next j
Next i
End Sub
I'm trying to parse a column that contains data in the following format in each cell -
pull: test1
or
pull: test2|pull: test3|.....
or
other: blah...
I only want a grab each "Pull: test" and place 1 in each row in a new worksheet like below, and ignore any parts of the cell that don't begin with "pull: " -
pull: test1
pull: test2
pull: test3
...
What I have so far just pulls the entire column and pastes into the same spreadsheet, I'm not sure how to separate the items in each cell into their own rows. I also can't get it to pull to a different worksheet correctly either (commented out my attempt)
Sub InStrDemo()
Dim lastrow As Long
Dim i As Integer, icount As Integer
'Sheets.Add.Name = "TEST"
lastrow = ActiveSheet.Range("A10000").End(xlUp).Row
For i = 1 To lastrow
If InStr(1, LCase(Range("E" & i)), "pull:") <> 0 Then
icount = icount + 1
'Sheets("TEST").Range("A" & icount & ":E" & icount) = Worksheets("SearchResults").Range("A" & i & ":E" & i).Value
Range("L" & icount) = Range("E" & i).Value
End If
Next i
End Sub
Untested, written on mobile.
Option Explicit
Sub testDemo()
Dim sourceSheet as worksheet
Set sourceSheet = ActiveSheet ' would be more reliable to qualify the workbook and worksheet by name'
Dim outputSheet as worksheet
Set outputSheet = thisworkbook.worksheets.add
Dim lastRow As Long
lastrow = sourceSheet.Range("A10000").End(xlUp).Row
' I assume column E needs to be parsed'
Dim arrayOfValues() as variant
arrayOfValues = sourceSheet.range("E1:E" & lastRow)
Dim rowIndex as long
Dim columnIndex as long
Dim splitString() as string
Dim cumulativeOffset as long
Dim toJoin(0 to 1) as string
toJoin(0) = "pull: test" ' Might speed up string concatenation below'
Dim outputArray() as string
With outputsheet.range("A1") ' The first row you want to start stacking from'
For rowIndex = 1 to lastRow
' Single dimensional, 0-based array'
splitString = VBA.strings.split(vba.strings.lcase$(arrayOfValues(rowIndex,1)), "pull: test",-1, vbbinarycompare)
Redim outputArray(1 to (ubound(splitString)+1), 1 to 1)
For columnIndex = lbound(splitString) to ubound(splitString)
toJoin(1) = splitString(columnIndex)
Outputarray(columnIndex+1,1) = VBA.strings.join(toJoin, vbnullstring)
Next columnIndex
'Instead of splitting upon a delimiter, then prepending the delimiter to each array element (as is done above), you could repeatedly call instr(), use mid$() to extract the sub-string, then increase the argument passed to the "Start" parameter in instr() (effectively moving from start to end of the string) -- until instr() returns 0. Then move on to the next string in the outer loop.'
.offset(cumulativeOffset,0).resize(Ubound(outputArray, 1), 1).value2 = outputArray
cumulativeOffset = cumulativeOffset + ubound(splitString)
Next rowIndex
End Sub
I am trying to split a string and create a loop for going through the cells in the column.There are a few challenges:
Split works for ActiveCell only.
Loop goes through all cells until LastRow but populates all cells
with split string values from ActiveCell only.
Split of Array starts with i = 0 even though there is Option Base 1
at the beginning of the Module.
How can I change the location of destination (e.g. instead of
splitting string next to existing data, is there an option to manage
column numbers)?
Thank you
Option Explicit
Option Base 1
Sub SplitStringLoop()
Dim txt As String
Dim i As Integer
Dim y As Integer
Dim FullName As Variant
Dim LastRow As Single
ReDim FullName(3)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
txt = ActiveCell.Value
FullName = Split(txt, "-")
For y = 2 To LastRow
For i = 1 To UBound(FullName)
Cells(y, i + 1).Value = FullName(i)
Next i
Next y
End Sub
Chris Nelisen outlined the reasons, I had this code written before he posted, so I'll post it anyway.
Option Explicit
Sub SplitStringLoop()
Dim txt As String
Dim i As Integer
Dim y As Integer
Dim FullName As Variant
Dim LastRow As Single
ReDim FullName(3)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For y = 2 To LastRow
Cells(y, 1).Select
txt = ActiveCell.Value
FullName = Split(txt, "-")
For i = 0 To UBound(FullName)
Cells(y, i + 2).Value = FullName(i)
Next i
Next
End Sub
To address the issues you list
Split acts on the string you pass to it. You are passing the active cell value to it.
You don't update the result of split (FullName) inside the loop. So what else do you expect?
Split Returns a zero-based, one-dimensional array. It says so right there in the help. Option Base 1 specifies the default lower bound, for when you don't specify it in a Dim statement.
You are specifying the column in your code Cells(y, i + 1) (i + 1 in this case). If you want it somewhere else, specify a different column.
this is my sulotion
Public Function CheckEmailsValid(EmailAddresses As String) As Boolean
On Error GoTo Err_1
Dim V_Tempi As Integer
Dim V_Email As Variant
For Each V_Email In Split(EmailAddresses, ";")
V_Tempi = V_Tempi + 1
If CheckEmailValid(V_Email) = False Then
MyMsgBox 2, "Email " & V_Tempi & " Is invalid"
CheckEmailValidFew = False
Exit Function
End If
Next
CheckEmailValidFew = True
Exit_1:
Exit Function
Err_1:
MyMsgBox 2, "Error !!" & vbCr & Err.Number & vbCr & Err.Description
End Function
bear with me on this question. I'm pretty sure it'll be easy for those who have knowledge in this field, but I do not know much about VBA or how to create loops in Excel to be creating this formula:
Please review the picture here
What I'm trying to construct is a loop that'll concatenate those numbers.
EX. I want to concatenate in this order A2,"-",B2; A3,"-",B2; A4,"-",B2.....A16,"-",B2
Once everything in A1- A16 is concatenated with B2, I want to move on to concatenating A1-A16 with B3.EX: A2,"-",B3; A3,"-",B3.....A16,"-",B3
I know this is possible because certain loops can be created to go through with this procedure, but I do not know VBA and am not sure if this is possible with just the pre-existing formulas in Excel. Thanks to anyone who helps.
From what you described, it's pretty simple nested loop. Below code will concatenate the way you wanted and store it to column C.
Sub MyConcat()
Const lColA As Long = 1
Const lColB As Long = 2
Const lColTxt As Long = 3 ' concatenated result in Column C
Dim oWS As Worksheet, sTxt As String
Dim lRowA As Long, lRowB As Long, lRowTxt As Long
Set oWS = ThisWorkbook.Worksheets("Sheet1") ' Change this to match yours
lRowA = 1
lRowTxt = 1
oWS.Columns(lColTxt).Clear ' remove previous data on Column C
Do Until IsEmpty(oWS.Cells(lRowA, lColA))
sTxt = ""
lRowB = 2
Do Until IsEmpty(oWS.Cells(lRowB, lColB))
sTxt = oWS.Cells(lRowA, lColA).Text & "-" & oWS.Cells(lRowB, lColB).Text
oWS.Cells(lRowTxt, lColTxt) = sTxt
lRowB = lRowB + 1
lRowTxt = lRowTxt + 1
Loop
lRowA = lRowA + 1
Loop
Set oWS = Nothing
End Sub
EDIT: This should fit in many situations of number of Parent SKUs.
Usable on your data in second image, including another set of "TuTi" and Parent SKUs of different length. Please try understand it, it will be a whole page of explanations.
Private Const lColA As Long = 1
Private Const lColB As Long = 2
Private Const lColTxt As Long = 3 ' concatenated result in Column C
Dim oWS As Worksheet, sGroup As String, lRowCurr As Long, lRowTxt As Long
Sub MyConcat()
Dim oRng As Range, lStopRow As Long
Set oWS = ThisWorkbook.Worksheets("Sheet1") ' Change this to match yours
lRowCurr = 1 ' Current Row index
lRowTxt = 1 ' Results from Row 1
sGroup = ""
With oWS
.Columns(lColTxt).Clear ' remove previous data on Column C
' Row of LastCell in current sheet + 1
lStopRow = .Cells.SpecialCells(xlLastCell).Row + 1
' Row of "Ctrl-Up" from LastCell Row at column A
lStopRow = .Cells(lStopRow, lColA).End(xlUp).Row + 1
' Start processing rows until until StopRow in column A
Do Until lRowCurr = lStopRow
Set oRng = .Cells(lRowCurr, lColA)
If IsGroupCell(oRng) Then
sGroup = oRng.Value ' Stores Group text
ElseIf IsParentSKU(oRng) Then
Call MyConcat2 ' Invoke the mix sub that writes the result in column C
End If
lRowCurr = lRowCurr + 1
Set oRng = Nothing
Loop
End With
Set oWS = Nothing
End Sub
Private Sub MyConcat2()
Dim sTxt As String, oRng As Range
Dim lRowA As Long, lRowB As Long
lRowA = lRowCurr + 1
Set oRng = oWS.Cells(lRowA, lColA)
' Stop mixing the values when it is a Group or Parent SKU row
Do Until IsGroupCell(oRng) Or IsParentSKU(oRng) Or IsEmpty(oRng)
sTxt = ""
lRowB = lRowCurr + 1
' Don't mix if it is a Parent SKU
Do Until IsParentSKU(oWS.Cells(lRowB, lColA)) Or IsEmpty(oWS.Cells(lRowB, lColB))
sTxt = oWS.Cells(lRowA, lColA).Text & "-" & oWS.Cells(lRowB, lColB).Text
oWS.Cells(lRowTxt, lColTxt) = sGroup & "-" & sTxt
lRowB = lRowB + 1
lRowTxt = lRowTxt + 1
Loop
lRowA = lRowA + 1
Set oRng = oWS.Cells(lRowA, lColA)
Loop
lRowCurr = lRowA - 1
Set oRng = Nothing
End Sub
Private Function IsGroupCell(oRng As Range) As Boolean
IsGroupCell = (Not IsNumeric(Left(oRng.Value, 1)) And IsEmpty(oRng.Offset(0, 1)))
End Function
Private Function IsParentSKU(oRng As Range) As Boolean
IsParentSKU = (IsNumeric(oRng.Value) And IsNumeric(oRng.Offset(0, 1).Value))
End Function