i would like to split the cells into TextA, TextB and TextC after "." and sort by the Text genre.
I also tried this:
Sub split_By_Text()
Set sh1 = ThisWorkbook.Sheets(1)
Set sh2 = ThisWorkbook.Sheets(2)
lrow1 = sh1.Range("A65356").End(xlUp).Row
For j = 2 To lrow1
splitVals = Split(sh1.Cells(j, 2), ".")
totalVals = UBound(splitVals)
For i = LBound(splitVals) To UBound(splitVals)
lrow2 = sh2.Range("B65356").End(xlUp).Row
lrow3 = sh2.Range("A65356").End(xlUp).Row
sh2.Cells(lrow3 + 1, 1) = sh1.Cells(j, 1)
'Debug.Print sh1.Cells(j, 1)
sh2.Cells(lrow2 + 1, 2) = splitVals(i)
'Debug.Print splitVals(i)
Next i
Next j
sh2.Activate
sh2.Range("A1") = "Drink ID"
sh2.Range("B1") = "Recipe_data"
sh2.Range("C1") = "Volume"
End Sub
But when i have only one sentence excel also add a line.
THX
Input:
Output:
Rearrange data to be split due to genre
Demonstrate an approach via array assignment and using the advanced restructuring features of the Application.Index() function:
Sub ReArrange()
Const GENRE& = 1, ID& = 2, TXT& = 5, TXTA& = 6, TXTB& = 7, TXTC& = 8 ' columns in variant array v2
With Sheet1 ' source sheet's CodeName (!)
' [0] define data range
Dim v, rng As Range, lastRow&
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:F" & lastRow)
' [1] get data
v = rng
' [2] rearrange array rows & columns (inserting 2 new columns)
v = Application.Index(v, _
Application.Transpose(getRows(v)), _
Array(0, 1, 2, 3, 0, 4, 5, 6))
v(1, GENRE) = "Genre": v(1, TXT) = "Text" ' renew headers
' [3] Fill in genre & tokens
Dim i&, ii&, cnt& ' item counters
Dim a&, b&, c& ' split item boundaries
For i = 2 To UBound(v) ' loop through v2
If v(i, ID) <> v(i - 1, ID) Then
cnt = 0: ii = 0
a = UBound(Split(v(i, TXTA), ".")) ' items TextA
b = UBound(Split(v(i, TXTB), ".")) ' items TextB
c = UBound(Split(v(i, TXTC), ".")) ' items TextC
End If
cnt = cnt + 1: ii = ii + 1 ' increment id and genre counters
Select Case cnt
Case Is <= a: v(i, GENRE) = "A"
v(i, GENRE) = "A": v(i, TXT) = Split(v(i, TXTA), ".")(ii - 1): If ii = a Then ii = 0
Case Is <= a + b
v(i, GENRE) = "B": v(i, TXT) = Split(v(i, TXTB), ".")(ii - 1): If ii = b Then ii = 0
Case Is <= a + b + c
v(i, GENRE) = "C": v(i, TXT) = Split(v(i, TXTC), ".")(ii - 1): If ii = c Then ii = 0
End Select
Next i
End With
' [4] write results back whereever you want (reducing array by 3 temporary columns)
Sheet2.Range("A1").Resize(UBound(v), UBound(v, 2) - 3) = v
End Sub
Helper function getRows()
Function getRows(arr) As Variant()
' Purpose: return an array of n-times repeated row numbers (based on number of splits)
Dim i&, ii&, j&, cnt&
Dim tmp(), tokens
ReDim tmp(0 To UBound(arr) * 10)
tmp(cnt) = 1: cnt = cnt + 1 ' one title row equals row no 1; increment new rows counter
For i = 2 To UBound(arr)
For j = 4 To 6 ' D:F
tokens = Split(arr(i, j), ".") ' upper boundary minus one because of right side point
For ii = LBound(tokens) To UBound(tokens) - 1
tmp(cnt) = i ' input row number as often as necessary
cnt = cnt + 1 ' increment counter
Next ii
Next
Next i
ReDim Preserve tmp(0 To cnt - 1) ' resize array to actual item size
getRows = tmp ' return function result array
'Debug.Print Join(tmp, ",") ' Array(1,2,2,2,3,3,3,3,3,3,3,3,4,4,4,4,4,4,5,5,5,5,5,5,6,6,6,6,6,6)
End Function
Related
In Excel 365, I have data in this format:
Or, in text:
1,2,3,7 A
4 B
5 C
6, 8 D
And I'm trying to split the data so it becomes this:
Or, in text
1 A
2 A
3 A
4 B
5 C
6 D
7 A
8 D
The leftmost row is always composed by numbers separated by comma or a single number. The right row can be any data.
The following VBA code will do most of what you want:
Sub ExpandRows()
Dim R As Range
Dim Rw As Range
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim S As String
Dim Tokens(1 To 1000) As String
Dim NTokens As Integer
Const Delim As String = ","
Dim StartSize As Integer
Dim TopCell As Range
Dim BotCell As Range
Set R = Selection
Set TopCell = R.Cells(1, 1)
Set BotCell = R.Cells(R.Rows.Count, 1)
StartSize = R.Rows.Count
For I = StartSize To 1 Step -1
S = R(I, 1)
If (S <> "") Then
J = 0
NTokens = 0
Do
K = InStr(J + 1, S, Delim)
If (K = 0) Then
NTokens = NTokens + 1
Tokens(NTokens) = Mid$(S, J + 1, Len(S) - J)
Else
NTokens = NTokens + 1
Tokens(NTokens) = Mid$(S, J + 1, (K - J - 1))
J = K
End If
Loop Until (K = 0)
End If
If (NTokens > 1) Then
For J = NTokens To 2 Step -1
If (Tokens(J) <> "") Then
Set Rw = R.Cells(I, 1).EntireRow
Call Rw.Select
Call Rw.Copy
Call R.Cells(I + 1, 1).EntireRow.Select
Call Rw.Insert(xlDown)
If (I = 1) Then
Set TopCell = TopCell.Cells(0, 1)
Set R = Range(TopCell, BotCell)
End If
Call R.Select
Call R.Cells(I + 1, 1).Select
R(I + 1, 1) = Tokens(J)
End If
Next J
R(I, 1) = Tokens(1)
End If
Next I
End Sub
This code will split the cells and create new rows with a single entry.
To use it, select the first column and execute the method.
After that, all you have to do is sort on the first column.
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 am trying to use a loop with vba to sum values from one worksheet to another. I am struggling with writing my code to match values from Sheet 4 and if the value matches then sum the categories from Sheet 1, if not then skip to the next office. I would also like to exclude certain categories from being included in the SUM loop for example, exclude "Book". Currently my macro is writing to Sheet3. Here is my code:
Option Explicit
Sub test()
Dim a, i As Long, ii As Long, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
a = Sheets("sheet1").Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not dic.Exists(a(i, 1)) Then dic(a(i, 2)) = dic.Count + 2
If Not .Exists(a(i, 1)) Then
Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
.Item(a(i, 1))(a(i, 2)) = .Item(a(i, 1))(a(i, 2)) + a(i, 3)
Next
ReDim a(1 To .Count + 1, 1 To dic.Count + 1)
a(1, 1) = Sheets("sheet1").[a1]
For i = 0 To dic.Count - 1
a(1, i + 2) = dic.Keys()(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .Keys()(i)
For ii = 2 To UBound(a, 2)
a(i + 2, ii) = .items()(i)(a(1, ii)) + 0
Next
Next
End With
With Sheets("sheet3").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.EntireColumn.ClearContents
Sheets("sheet1").[a1].Copy .Rows(1)
.Value = a: .Columns.AutoFit: .Parent.Activate
End With
End Sub
This is how the data looks
and this is the output that is desired
In this example, we will use arrays to achieve what you want. I have commented the code so that you shall not have a problem understanding it. However if you still do then simply ask :)
Input
Output
Logic
Find last row and last column of input sheet
Store in an array
Get unique names from Column A and Row 1
Define output array
Compare array to store sum
Create new sheet and output to that sheet
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet, wsNew As Worksheet
Dim tempArray As Variant, OutputAr() As Variant
Dim officeCol As New Collection
Dim productCol As New Collection
Dim itm As Variant
Dim lrow As Long, lcol As Long, totalsum As Long
Dim i As Long, j As Long, k As Long
'~~> Input sheet
Set ws = Sheet1
With ws
'~~> Get Last Row and last column
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
lcol = .Cells(1, Columns.Count).End(xlToLeft).Column
'~~> Store it in a temp array
tempArray = .Range(.Cells(2, 1), .Cells(lrow, lcol)).Value
'~~> Create a unique collection using On error resume next
On Error Resume Next
For i = LBound(tempArray) To UBound(tempArray)
officeCol.Add tempArray(i, 1), CStr(tempArray(i, 1))
productCol.Add tempArray(i, 2), CStr(tempArray(i, 2))
Next i
On Error GoTo 0
End With
'~~> Define you new array which will hold the desired output
ReDim OutputAr(1 To officeCol.Count + 1, 1 To productCol.Count + 1)
'~~> Store the rows and columns in the array
i = 2
For Each itm In officeCol
OutputAr(i, 1) = itm
i = i + 1
Next itm
i = 2
For Each itm In productCol
OutputAr(1, i) = itm
i = i + 1
Next itm
'~~> Calculate sum by comparing the arrays
For i = 2 To officeCol.Count + 1
For j = 2 To productCol.Count + 1
totalsum = 0
For k = LBound(tempArray) To UBound(tempArray)
If OutputAr(i, 1) = tempArray(k, 1) And _
OutputAr(1, j) = tempArray(k, 2) Then
totalsum = totalsum + tempArray(k, 3)
End If
Next k
OutputAr(i, j) = totalsum
Next j
Next i
'~~> Create a new sheet
Set wsNew = ThisWorkbook.Sheets.Add
'~~> Outout the array
wsNew.Range("A1").Resize(officeCol.Count + 1, productCol.Count + 1).Value = OutputAr
End Sub
I have an excel table where there are part codes in a column and for every part code, there are 3-4 subsections (1100-1400) with information which I need to attach to the part code in a column view.
The number of created rows depends on if there is data entered into subsection 1400. 1100-1300 has always information and needs to be converted into a table.
I don't even know from where to start so currently I have no code to show
I added a picture of how the data is represented and what the result should look like:
You could do it like that
Option Explicit
Sub TransformA()
Dim rg As Range
Dim lastRow As Long, lineNo As Long, i As Long, j As Long
Dim shInput As Worksheet, shResult As Worksheet
Dim vDat As Variant, resDat As Variant
Dim subSection As String
' Make sure you run the code with the data in the Activesheet
Set shInput = ActiveSheet
' And you have data which starts in row 4 with the heading in row 3
' otherwise adjust accordingly
lastRow = shInput.Range("A4").End(xlDown).Row
Set rg = shInput.Range("A4:I" & lastRow)
vDat = rg
ReDim resDat(1 To UBound(vDat, 1) * 4, 1 To 4)
lineNo = 1
For j = 1 To UBound(vDat, 1)
For i = 0 To 2
Select Case i
Case 0: subSection = "1100"
Case 1: subSection = "1200"
Case 2: subSection = "1300"
End Select
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
Next
i = 3
subSection = "1400"
If Len(vDat(j, 2 + 2 * i)) = 0 And Len(vDat(j, 3 + 2 * i)) = 0 Then
lineNo = lineNo + 3
Else
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
lineNo = lineNo + 4
End If
Next
' Output the result to a new sheet
Set shResult = Sheets.Add
With shResult
.Cells(1, 1).Value = "Part Code"
.Cells(1, 2).Value = "Subsection"
.Cells(1, 3).Value = "Time"
.Cells(1, 4).Value = "Text"
End With
shResult.Range("A2").Resize(UBound(resDat, 1), 4) = resDat
End Sub
I need to track a person in a data sheet to determine from which location to which location the person moved.
If a person appears more then one time in Column J that means the person has changed the location and the location value is in Column L. For this I have the following code:
=IF(J18=J19;IF(COUNTIF(J:J;J18)>1; "From "&L18 &" to "& IF(J18=J19;L19;"");"");"")
The problem is if the person changes the location more than two times. In Column O to Column AA I have the months of the year which determines the location of the person.
How can I modify this code to do the above:
=IF(J18=J19;IF(COUNTIF(J:J;J18)>1; "From "&L18 &" to "& IF(J18=J19;L19;"");"");"")
Here is a User Defined Function (aka UDF) to accomplish the task.
Function my_Travels(nm As Range, loc As Range, cal As Range)
Dim n As Long, cnt As Long, v As Long, vLOCs As Variant, vTMPs As Variant
Dim iLOC As Long, sTMP As String
my_Travels = vbNullString '"no travels"
cnt = Application.CountIf(nm.EntireColumn, nm(1))
If Application.CountIf(nm, nm(1)) = cnt And cnt > 1 Then
Set loc = loc.Rows(1).Resize(nm.Rows.Count, loc.Columns.Count)
Set cal = cal.Rows(1).Resize(nm.Rows.Count, cal.Columns.Count)
'seed the array
ReDim vLOCs(1 To cnt, 1 To cnt)
For v = LBound(vLOCs, 1) To UBound(vLOCs, 1)
vLOCs(v, 1) = cal.Columns.Count + 1
vLOCs(v, 2) = cal.Columns.Count + 1
Next v
'collect the values into the array
For n = 1 To nm.Rows.Count
If nm.Cells(n, 1).Value2 = nm.Cells(1, 1).Value2 Then
iLOC = Application.Match(1, Application.Index(cal, n, 0), 0)
For v = LBound(vLOCs, 1) To UBound(vLOCs, 1)
If vLOCs(v, 1) = cal.Columns.Count + 1 Then
vLOCs(v, 1) = iLOC
vLOCs(v, 2) = n
Exit For
End If
Next v
End If
Next n
'sort the values in the array
For v = LBound(vLOCs, 1) To (UBound(vLOCs, 1) - 1)
For n = (v + 1) To UBound(vLOCs, 1)
If vLOCs(v, 1) > vLOCs(n, 1) Then
vTMPs = Array(vLOCs(v, 1), vLOCs(v, 2))
vLOCs(v, 1) = vLOCs(n, 1)
vLOCs(v, 2) = vLOCs(n, 2)
vLOCs(n, 1) = vTMPs(0)
vLOCs(n, 2) = vTMPs(1)
Exit For
End If
Next n
Next v
'concatenate the locations from the array
For v = LBound(vLOCs) To (UBound(vLOCs) - 1)
sTMP = sTMP & "From " & loc.Cells(vLOCs(v, 2), 1) & " to " & loc.Cells(vLOCs(v + 1, 2), 1) & "; "
Next v
'truncate the string and return it
sTMP = Left(sTMP, Len(sTMP) - 2)
my_Travels = sTMP
End If
End Function
The Locations and the Calendar cells only need to be defined by the first row. Each has its height (i.e. rows) redefined to maintain consistency with the list of names.
In AB2 (as above) the formula is,
=my_Travels(J2:J$8, L2, O2:AA2)
Fill down as necessary.