I am trying to figure out how to join every cell (normal text) in the D column between the range I have set up in the A column. While searching I came across variations of the concatenate, textjoin and other functions but could not seem to find the right option.
There are around 8000 values in my file(ID value in column A) so it should be automatically filled and not manual. since it would take weeks to complete...
i've added a visual representation of the problem
The solution would be to have all cells selected in column D between the value '1' and '2' in column A and joined togheter in the E column in the row where the the cell in the A column isn't blank.
I hope someone can help me with this problem.
Try this code, please. It should be very fost, using arrays and returns the built strings at once at the end:
Sub testJoinBetweenLimits()
Dim sh As Worksheet, arrInit As Variant, arrFin As Variant
Dim strInit As String, i As Long, j As Long, refRow As Long
Set sh = ActiveSheet 'use here your sheet
arrInit = sh.Range("A2:D" & sh.Range("D" & Cells.Rows.Count).End(xlUp).Row).value
ReDim arrFin(1 To 1, 1 To UBound(arrInit, 1))
For i = 1 To UBound(arrInit, 1)
If arrInit(i, 1) <> "" Then strInit = arrInit(i, 4): refRow = i: j = i + 1
Do While arrInit(j, 1) = ""
If arrInit(j, 4) <> "" Then
strInit = strInit & ", " & arrInit(j, 4)
Else
arrFin(1, j) = Empty
End If
j = j + 1
If j >= sh.Range("D" & Cells.Rows.Count).End(xlUp).Row Then
arrFin(1, refRow) = strInit
ReDim Preserve arrFin(1 To 1, 1 To refRow)
GoTo Ending
End If
Loop
i = j - 1
arrFin(1, refRow) = strInit: strInit = "": j = 0
Next i
Ending:
sh.Range("E2").Resize(UBound(arrFin, 2), 1).value = WorksheetFunction.Transpose(arrFin)
End Sub
Related
I get some unclean data from a text file, and in the text file, I process it as per the data in the VBA script, which gives the following output.
This is the Raw String.
1* student 1*2018-01-01*1*1234122
2* student 2*2017-01-01*1*54654654234
3* student 3*2015-01-01*4*54234654654
4* student 4*2012-01-01*5*546542345654
I wanted the output in different cells, as mentioned below in any open worksheet in excel.
Roll No
Student Name
Date of Birth
class
phone
1
student 1
2018-01-01
1
1234122
2
student 2
2017-01-01
1
54654654234
3
student 3
2015-01-01
4
54234654654
4
student 4
2012-01-01
5
546542345654
I tried various sources but couldn't get the expected output.
Any help will be appreciated.
Please, try the next way. It assumes that the whole text you show is in a single cell, not in different linens. But the above way will also deal with a single row:
Sub extractTextDelimSep()
Dim x As String, arr, arrLine, arrFin, cols As Long, i As Long, j As Long
x = "1* student 1*2018-01-01*1*1234122" & vbCr & _
"2* student 2*2017-01-01*1*54654654234" & vbCr & _
"3* student 3*2015-01-01*4*54234654654" & vbCr & _
"4* student 4*2012-01-01*5*546542345654"
arr = Split(x, vbCr) 'split the rows
cols = UBound(Split(arr(0), "*")) + 1 'determine the columns number per row
ReDim arrFin(1 To UBound(arr) + 1, 1 To cols) 'ReDim the final array
For i = 0 To UBound(arr)
arrLine = Split(Replace(arr(i), " ", ""), "*")
For j = 0 To UBound(arrLine)
arrFin(i + 1, j + 1) = arrLine(j)
Next j
Next i
Range("B2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
End Sub
Instead using x as a built string you my have the string in a cell and you can use x = ActiveCell.value.
It is easy to transform the above code in a function, too...
Edited:
You can use the next function:
Function extractTextDelimSep(x As String) As Variant
Dim arr, arrLine, arrFin, cols As Long, i As Long, j As Long
arr = Split(x, vbCr)
cols = UBound(Split(arr(0), "*")) + 1
ReDim arrFin(1 To UBound(arr) + 1, 1 To cols)
For i = 0 To UBound(arr)
arrLine = Split(Replace(arr(i), " ", ""), "*")
For j = 0 To UBound(arrLine)
arrFin(i + 1, j + 1) = arrLine(j)
Next j
Next i
extractTextDelimSep = arrFin
End Function
If everything is in the same cell (in column A:A), you should call it in the next way:
Sub TestextractTextDelimSep()
Dim x As String, arr
x = ActiveCell.Value
arr = extractTextDelimSep(x)
'drop the array content at once:
Range("B" & ActiveCell.row).Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
If the string is distributed one line of a (different) cell, you can use:
Sub TestextractTextDelimSepRange()
Dim lastR As Long, arr, i As Long
lastR = Range("A" & rows.count).End(xlUp).row
For i = 1 To lastR
arr = extractTextDelimSep(Range("A" & i).Value)
Range("B" & i).Resize(1, UBound(arr, 2)).Value = arr
Next i
End Sub
For this last case, in Excel 365 it can be used as UDF function, being called from the cell as formula:
=extractTextDelimSep(A1) 'in A1 should be the line to be split
I'm trying to group a number from E column starting with 1, the result should be like as below:
Column
E I
1 1-52
. 54-56
. 58-59
.
52
54
55
56
58
59
And I start to write like this:
Sub Group_Numbers()
Dim a As Variant, b As Variant
Dim i As Long, k As Long
Range("I1") = Range("E1")
k = 1
a = Range("E1", Range("E" & Rows.Count).End(xlUp)).Value
ReDim b(1 To UBound(a), 1 To 1)
For i = 2 To UBound(a)
If a(i, 1) <> Val(a(i - 1, 1)) + 1 Then
k = k + 1
b(k, 1) = a(i, 1)
Else
b(k, 1) = Split(b(k, 1), "-")(0) & -a(i, 1)
End If
Next i
Range("I2").Resize(l).Value = b
End Sub
However, it prompts an error 9 subscript out of range. Hope to get help right here.
Thanks a lot!
I would do the following
Option Explicit
Public Sub Example()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
Dim Data() As Variant ' read input data into array
Data = ws.Range("E1", "E" & LastRow).Value2
Dim OutData() As Variant ' define output array
ReDim OutData(1 To UBound(Data, 1), 1 To 1) As Variant
Dim iOut As Long
iOut = 1
Dim StartVal As Long
StartVal = Data(1, 1) ' initialize start value of a group
Dim iRow As Long
For iRow = 2 To UBound(Data, 1) ' loop through values
' check if value is previous value +1
If Data(iRow, 1) <> Data(iRow - 1, 1) + 1 Then
' if not write output from StartVal to previos value
OutData(iOut, 1) = StartVal & "-" & Data(iRow - 1, 1)
iOut = iOut + 1
' and set curent value as new group start
StartVal = Data(iRow, 1)
End If
Next iRow
' close last group
OutData(iOut, 1) = StartVal & "-" & Data(iRow - 1, 1)
' write array back to cells
ws.Range("I1").Resize(RowSize:=iOut).NumberFormat = "#" 'format cells as text so `1-2` does not get converted into date.
ws.Range("I1").Resize(RowSize:=iOut).Value2 = OutData
End Sub
Alternative via Excel's Filter() function (vers. MS 365)
Disposing of the new dynamic array features you can profit from a worksheet-related formula evaluation via a tabular filter upon the data range rows compared with the same range shifted by 1 resulting in an array of endRows numbers. This is the base for a results array which joins start and end values.
The following code allows to define a flexible source range, as the evaluation takes care of the actual start row in the indicated data column.
Example call //edited responding to comment
Sub Grouping()
'0) get data
Dim src As Range
Set src = Sheet1.Range("E1:E59") ' change to your needs
Dim data As Variant
If src.Rows.Count > 1 Then ' is the usual case
data = src.Value2 ' get 2-dim datafield array
Else ' a one liner is the exception
ReDim data(1 To 1, 1 To 1) ' create 2-dim by ReDim
data(1, 1) = Application.Index(src, 1, 1)
End If
'1a)prepare formula evaluation of endRows
Dim EndPattern As String
EndPattern = "=LET(data,$,FILTER(ROW(OFFSET(data,1,0))-" & src.Row & ",ABS(OFFSET(data,1,0)-data)>1))"
EndPattern = Replace(EndPattern, "$", src.Address(False, False))
'1b)evaluate formula
Dim endRows: endRows = src.Parent.Evaluate(EndPattern)
'~~~~~~~~~~~~~~
'2) get results
'~~~~~~~~~~~~~~
Dim results: results = getResults(data, endRows) '<< Help function getResults
'3) write to any target
With Sheet1.Range("I1")
.Resize(UBound(results), 1) = results
End With
End Sub
Help function getResults() //added responding to comment
The usual result of an evaluation is a 1-based 2-dim array with two exceptions code has to provide for:
a) non-findings (which would result only in a returned error value),
b) only a single return value (which is a 1-dim array).
Not enough with these exceptions, the tricky comparison of identical endRows blocks - being shifted by 1 row - makes it necessary to check for the actual last row number if not comprised in endRows. - Imo this might have been the commented issue by #TecLao.
Function getResults(ByRef data, ByRef endRows)
'Purpose: combine value ranges
Dim results As Variant
Dim n As Long: n = UBound(data)
'a) no end row returned by shift-formula evaluation
If IsError(endRows) Then ReDim endRows(1 To 1): endRows(1) = n
'b) one end row found
If Application.WorksheetFunction.CountA(endRows) = 1 Then
ReDim results(1 To IIf(endRows(1) < n, 2, 1), 1 To 1)
'write results
results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1), 1)
If UBound(results) = 2 Then
results(2, 1) = _
"'" & data(endRows(1) + 1, 1) & _
"-" & _
data(n, 1)
End If
'c) several end rows found
Else
Dim increment As Long
If endRows(UBound(endRows), 1) < n Then increment = 1
'write results
ReDim results(1 To UBound(endRows) + increment, 1 To 1)
results(1, 1) = "'" & data(1, 1) & "-" & data(endRows(1, 1), 1)
Dim i As Long
For i = 2 To UBound(endRows)
results(i, 1) = _
"'" & _
data(endRows(i - 1, 1) + 1, 1) & _
"-" & _
data(endRows(i, 1), 1)
Next
If increment Then
results(i, 1) = "'" & data(endRows(i - 1, 1) + 1, 1) & "-" & data(n, 1)
End If
End If
'function return
getResults = results
End Function
I try to find a vba solution for the following problem:
I have two columns and try to group column1 in a comma separate way to have less rows.
e.g.
example:
I tried this, and it worked - but It take too long (about 300.000 Rows). Is there any better solution that task?
*Its just one part of my macro
For Each r In fr
If st = "" Then
st = Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "L").Value))
Else
If Not IsInArray(Split(st, ","), ws.Cells(r.row, "L").Value) Then
st = st & ", " & Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "L").Value))
End If
End If
If usrCheck = True Then
If str = "" Then
str = Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "A").Value))
Else
If Not IsInArray(Split(str, ","), ws.Cells(r.row, "A").Value) Then
str = str & ", " & Application.WorksheetFunction.Clean(Trim(ws.Cells(r.row, "A").Value))
End If
End If
End If
Next
Maybe using Dictionary would be fast. What about:
Sub Test()
Dim x As Long, lr As Long, arr As Variant
Dim dict1 As Object: Set dict1 = CreateObject("Scripting.Dictionary")
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
With Sheet1 'Change accordingly
'Return your last row from column A
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array and loop through it
arr = .Range("A2:B" & lr).Value
For x = LBound(arr) To UBound(arr)
dict1(arr(x, 2)) = arr(x, 2)
Next
'Loop through dictionary filling a second one
For Each Key In dict1.keys
For x = LBound(arr) To UBound(arr)
If arr(x, 2) = Key Then dict2(arr(x, 1)) = arr(x, 1)
Next x
.Range("F" & .Cells(.Rows.Count, 6).End(xlUp).Row + 1) = Key
.Range("G" & .Cells(.Rows.Count, 7).End(xlUp).Row + 1) = Join(dict2.Items, ", ")
dict2.RemoveAll
Next
End With
End Sub
This will get you all unique items from column A though, so if there can be duplicates and you want to keep them, this is not for you =)
Try also this, please. It works only in memory and on my computer takes less then 3 seconds for 300000 rows. The range must be filtered, like in your picture. If not, the filtering can also be easily automated.
Private Sub CondensData()
Dim sh As Worksheet, arrInit As Variant, arrIn As Variant, i As Long
Dim arrFinal() As Variant, lastRow As Long, Nr As Long, El As Variant
Dim strTemp As String, k As Long
Set sh = ActiveSheet
lastRow = sh.Cells(sh.Rows.count, "A").End(xlUp).Row
arrIn = sh.Range("B2:B" & lastRow + 1).Value
'Determine the number of the same accurrences:
For Each El In arrIn
i = i + 1
If i >= 2 Then
If arrIn(i, 1) <> arrIn(i - 1, 1) Then Nr = Nr + 1
End If
Next
ReDim arrFinal(Nr, 1)
arrInit = sh.Range("A2:B" & lastRow).Value
For i = 2 To UBound(arrInit, 1)
If i = 1 Then
strTemp = arrInit(1, 1)
Else
If arrInit(i, 2) = arrInit(i - 1, 2) Then
If strTemp = "" Then
strTemp = arrInit(i, 1)
Else
strTemp = strTemp & ", " & arrInit(i, 1)
End If
Else
arrFinal(k, 0) = arrInit(i - 1, 2)
arrFinal(k, 1) = strTemp
k = k + 1: strTemp = ""
End If
End If
Next i
sh.Range("C2:D" & lastRow).Clear
sh.Range("C2:D" & k - 1).Value = arrFinal
sh.Range("C:D").EntireColumn.AutoFit
MsgBox "Solved..."
End Sub
It will return the result in columns C:D
I am relatively new to VBA, and any help to get this problem solved will be greately appreciated!
I want Excel to look at two columns of text values, and only return the unique ones, for both columns. But I want the two columns to "correspond" to one another, so that the unique values for the first column is returned, and the unique values corresponding to each of the unique values in that column is returned next to it.
I.e. if the columns are the following:
Column 1: a a a d d g g g g
And the second column's values are
Column 2: 3 3 2 1 1 7 8 8 9
I would like to first look at column 1. Here, the first unique value is a. Then, take all the unique values in column 2 (i.e. 3 and 2). So (1,1)=a, (1,2)=3, (2,2)=2 and (2,1)=empty. Then, below, is the next unique value, so (3,1)=d, (3,2)=2, (4,1)=empty and (4,2)=1. Then (5,1)=g, and (5,2)=7, (6,1)=empty, (6,2)=8, (7,1)=empty, and (7,2)=9.
It's a little tricky to explain, but I hope it is still possible to get the point!
Thank you!
This code will do that for you
Option Explicit
Sub Main()
Dim r1 As Range
Set r1 = Application.InputBox(prompt:="Select first range", Type:=8)
Dim r2 As Range
Set r2 = Application.InputBox(prompt:="Select second range", Type:=8)
If r1.Rows.Count <> r2.Rows.Count Then
MsgBox "ranges aren't equal in rows, restart the macro!", vbCritical
Exit Sub
End If
ReDim arr(0) As String
Dim i As Long
For i = 1 To r1.Rows.Count
arr(UBound(arr)) = r1.Rows(i) & "###" & r2.Rows(i)
ReDim Preserve arr(UBound(arr) + 1)
Next i
RemoveDuplicate arr
ReDim Preserve arr(UBound(arr) - 1)
With Sheets(2)
.Activate
.Columns("A:B").ClearContents
For i = LBound(arr) To UBound(arr)
.Range("A" & i + 1) = Split(arr(i), "###")(0)
.Range("B" & i + 1) = Split(arr(i), "###")(1)
Next i
For i = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
If StrComp(.Range("A" & i).Offset(-1, 0), .Range("A" & i), vbTextCompare) = 0 Then
.Range("A" & i) = vbNullString
End If
Next i
End With
End Sub
Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub
lowBound = LBound(StringArray): UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound: tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B
tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub
What happens is you are asked to select each column with your mouse. So assuming your spreadsheet looks somehow like below picture then select your two desired columns. First column and then you will be asked for the second one. (select whats in red)
Repeat for the second column and your results will be reprinted in Sheet2
I have data that I need to split into individual points. My macro charts the data, as a scatter plot, with: Column A as the title of the chart, Column B as the X axis, and Columns C and D as the Y axis. What I need is for when the Product ID has more than 1 number listed to split the numbers out into their own rows and keep the columns B, C, and D the same for each row created form the original. So for row 167, I would want 3 rows (001,002,003) each with packaging, 200, and 100, in B, C, and D respectively. I am not sure where to begin. I tried to build a macro but, I immediately got tripped up when I tried to record a "Find" Formula to run on the data. Any help would be greatly appreciated.
Column A: 001, 002, 003 // Column B:packaging // Column C:200 // Column D:100
Sorry I couldn't post a screenshot of my data, the forum won't let me. If you have any questions please let me know, I will be sure to check in frequently.
Thanks in advance.
I worte this VERY quickly and without much care for efficiency, but this should do the trick:
Sub SplitUpVals()
Dim i As Long
Dim ValsToCopy As Range
Dim MaxRows As Long
Dim ValToSplit() As String
Dim CurrentVal As Variant
MaxRows = Range("A1").End(xlDown).Row
For i = 1 To 10000000
ValToSplit = Split(Cells(i, 1).Value, ",")
Set ValsToCopy = Range("B" & i & ":D" & i)
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(i, 1).Value = CurrentVal
Range("B" & i & ":D" & i).Value = ValsToCopy.Value
Cells(i + 1, 1).EntireRow.Insert
i = i + 1
MaxRows = MaxRows + 1
Next
Cells(i, 1).EntireRow.Delete
If i > MaxRows Then Exit For
Next i
End Sub
As a note, make sure there's no data in cells beneath your data as it might get deleted.
You will need to parse the data in column A. I would do this by splitting the string in to an array, and then iterate over the array items to add/insert additional rows where necessary.
Without seeing your worksheet, I would probably start with something like this, which will split your cell value from column A in to an array, and then you can iterate over the items in the array to manipulate the worksheet as needed.
Sub TestSplit()
Dim myString as String
Dim myArray() as String
Dim cell as Range
Dim i as Long
For each cell in Range("A2",Range("A2").End(xlDown))
myString = cell.Value
myArray = Split(myString, ",") '<-- converts the comma-delimited string in to an array
For i = lBound(myArray) to uBound(myArray)
If i >= 1 Then
'Add code to manipulate your worksheet, here
End If
Next
Next
End Sub
This is a better solution (now that I had more time :) ) - Hope this does the trick!
Sub SplitUpVals()
Dim AllVals As Variant
Dim ArrayIndex As Integer
Dim RowLooper As Integer
AllVals = Range("A1").CurrentRegion
Range("A1").CurrentRegion.Clear
RowLooper = 1
For ArrayIndex = 1 To UBound(AllVals, 1)
ValToSplit = Split(AllVals(ArrayIndex, 1), ",")
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(RowLooper, 1).Value = CurrentVal
Cells(RowLooper, 2).Value = AllVals(ArrayIndex, 2)
Cells(RowLooper, 3).Value = AllVals(ArrayIndex, 3)
Cells(RowLooper, 4).Value = AllVals(ArrayIndex, 4)
RowLooper = RowLooper + 1
Next
Next ArrayIndex
End Sub
Sub DivideData()
'This splits any codes combined into the same line, into their own separate lines with their own separate data
Dim a, b, txt As String, e, s, x As Long, n As Long, i As Long, ii As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(1).Value))
x = Len(txt) - Len(Replace(txt, ",", "")) + .Rows.Count
ReDim b(1 To x * 2, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
For Each e In Split(a(i, 1), ",")
If e <> "" Then
For Each s In Split(e, "-")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 1) = s
Next
End If
Next
Next
With .Resize(n)
.Columns(1).NumberFormat = "#"
.Value = b
End With
End With
End Sub