I have the following table:
Our main category is fruit/vegetable, its subcategory is their type and the subcategory of their type is the color. For hours I am trying to achieve to following output with a formula, but without success..
The main product type should not duplicate itself in the row. If there are duplicates within the "fruit/vegetable type" we need to take the type only once and all of its colors. Sorry if the explanation is not good. Here is it graphically:
This is a solution using a dictionary.
Sub test()
Dim vDB, vR()
Dim Dic As Object 'Dictionary
Dim Fruit As Object 'Dictionary
Dim Ws As Worksheet, toWs As Worksheet
Dim i As Long, j As Long, r As Long
Dim k As Integer
Set Ws = Sheets(1) 'set your data Sheet
Set toWs = Sheets(2) 'set your result Sheet
vDB = Ws.Range("a1").CurrentRegion
Set Dic = CreateObject("Scripting.Dictionary")
Set Fruit = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(vDB, 1)
If Dic.Exists(vDB(i, 1)) Then
Else
Dic.Add vDB(i, 1), vDB(i, 1)
End If
Next i
r = Dic.Count
ReDim vR(1 To r, 1 To 1000)
For i = 1 To r
vR(i, 1) = Dic.Items(i - 1)
k = 1
For j = 2 To UBound(vDB, 1)
If vDB(j, 1) = Dic.Items(i - 1) Then
If Fruit.Exists(vDB(j, 2)) Then
k = k + 1
vR(i, k) = vDB(j, 3)
Else
Fruit.Add vDB(j, 2), vDB(j, 2)
k = k + 2
vR(i, k - 1) = vDB(j, 2)
vR(i, k) = vDB(j, 3)
End If
End If
Next j
Next i
With toWs
.Range("a1").CurrentRegion.Clear
.Range("a1").Resize(r, 1000) = vR
End With
End Sub
Related
The code I have takes cells containing the delimiter (; ) from a column, and creates new rows (everything except the column is duplicated) to separate those values.
What I have
I need this for multiple columns in my data, but I don't want the data to overlap (ex: for 3 columns, I want there to be only one value per row in those 3 columns). It would be ideal if I could select multiple columns instead of only one as my code does now.
What I want
Sub splitByCol()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet").Range("J2000").End(xlUp)
Do While r.Row > 1
ar = Split(r.Value, "; ")
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
Try this code
Sub Test()
Dim a, x, e, i As Long, ii As Long, iii As Long, k As Long
a = Range("A1").CurrentRegion.Value
ReDim b(1 To 1000, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
For ii = 2 To 3
x = Split(a(i, ii), "; ")
For Each e In x
k = k + 1
b(k, 1) = k
b(k, 2) = IIf(ii = 2, e, Empty)
b(k, 3) = IIf(ii = 3, e, Empty)
b(k, 4) = a(i, 4)
Next e
Next ii
Next i
Range("A5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I'd go this way
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, -1)
With .Resize(UBound(currFirstColValues) + 1)
.Value = currFirstColValues
.Offset(, 2).Value = thirdColValues(iRow, 1)
End With
End With
With .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 1)
With .Resize(UBound(currSecondColValues) + 1)
.Value = currSecondColValues
.Offset(, 1).Value = thirdColValues(iRow, 1)
End With
End With
Next
End With
End Sub
Follow the code step by step by pressing F8 while the cursor is in any code line in the VBA IDE and watch what happens in the Excel user interface
EDIT
adding edited code for a more "parametric" handling by means of a helper function
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
WriteOne .Cells(.Rows.Count, "C").End(xlUp).Offset(1), _
currFirstColValues, thirdColValues(iRow, 1), _
-1, 2
WriteOne .Cells(.Rows.Count, "B").End(xlUp).Offset(1), _
currSecondColValues, thirdColValues(iRow, 1), _
1, 1
Next
End With
End Sub
Sub WriteOne(refCel As Range, _
currMainColValues As Variant, thirdColValue As Variant, _
mainValuesOffsetFromRefCel As Long, thirdColValuesOffsetFromRefCel As Long)
With refCel.Offset(, mainValuesOffsetFromRefCel)
With .Resize(UBound(currMainColValues) + 1)
.Value = currMainColValues
.Offset(, thirdColValuesOffsetFromRefCel).Value = thirdColValue
End With
End With
End Sub
Please, use the next code. It uses arrays and should be very fast for big ranges to be processed, working mostly in memory:
Sub testSplitInsert()
Dim sh As Worksheet, lastR As Long, arr, arrSp, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("B1:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 10, 1 To 3) 'maximum to keep max 10 rows per each case
k = 1 'initialize the variable to load the final array
For i = 1 To UBound(arr)
arrSp = Split(Replace(arr(i, 1)," ",""), ";") 'trim for the case when somebody used Red;Blue, instead of Red; Blue
For j = 0 To UBound(arrSp)
arrFin(k, 1) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
arrSp = Split(Replace(arr(i, 1)," ",""), ";")
For j = 0 To UBound(arrSp)
arrFin(k, 2) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
Next
sh.Range("G1").Resize(k - 1, 3).Value = arrFin
End Sub
It processes the range in columns "B:D" and returns the result in columns "G:I". It can be easily adapted to process any columns range and return even overwriting the existing range, but this should be done only after checking that it return what you need...
I have data like this in excel, Column Animal No and Clinical Signs have text data seperated by comma.
Input
i wanted to get the output like this i dont want to use power pivot as the results will be pasted as query table. I want vba code to do the same and paste it in the same sheet
Try,
Sub test()
Dim Ws As Worksheet
Dim vDB As Variant
Dim vR() As Variant
Dim a As Variant, b As Variant
Dim i As Long, n As Long, r As Long
Dim j As Integer, k As Integer
Set Ws = Sheets(1)
vDB = Ws.Range("a1").CurrentRegion
r = UBound(vDB, 1)
For i = 2 To r
a = Split(vDB(i, 2), ",")
b = Split(vDB(i, 4), ",")
For j = 0 To UBound(a)
For k = 0 To UBound(b)
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
vR(1, n) = vDB(i, 1)
vR(2, n) = Trim(a(j))
vR(3, n) = vDB(i, 3)
vR(4, n) = Trim(b(k))
vR(5, n) = vDB(i, 5)
Next k
Next j
Next i
With Ws
.Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
End With
End Sub
I have a very big excel file and i want to transfer all information from worksheet to the variant variable.
I don't need all the rows from the file, so I want to chose rows that I am interested in.
I have tried to make complex Range variable using Union to select rows that i am interested in.
The problem is that my program doesn't increase range if useful inormation is divided by the not wanted rows.
example:
I have got table like this:
123|1|1|1
123|2|2|2
456|3|3|3
123|4|4|4
I want rows with 123 in the first column, but then i am using Union function, I got only first two rows, but not the fourth.
I need:
123|1|1|1
123|2|2|2
123|4|4|4
but recieve:
123|1|1|1
123|2|2|2
Below will be a part of my code. This part is in the cycle
r - Range
WS - Worksheet
Set r = WS.Range("A1:A1")
Can somebody help me with this. I am looking for a solution for hour already.
If WS.Cells(i, 1).Value = "123" Then
If r.Columns.Count() < 2 Then
Set r = WS.Range(WS.Cells(i, 1), WS.Cells(i, 4))
Else
Set r = Union(r, WS.Range(WS.Cells(i, 1), WS.Cells(i, 4)))
End If
End If
This works, using your approach:
Sub x()
Dim r As Range, ws As Worksheet, i As Long
Dim j As Long
Set ws = ActiveSheet
Set r = ws.Range("A1")
For i = 1 To 4
If ws.Cells(i, 1).Value = 123 Then
If r.Columns.Count < 2 Then
Set r = ws.Range(ws.Cells(i, 1), ws.Cells(i, 4))
Else
Set r = Union(r, ws.Range(ws.Cells(i, 1), ws.Cells(i, 4)))
End If
End If
Next i
For j = 1 To r.Areas.Count
Range("G" & Rows.Count).End(xlUp)(2).Resize(r.Areas(j).Rows.Count, r.Areas(j).Columns.Count).Value = r.Areas(j).Value
Next j
End Sub
Using an array approach, the results are stored in v2.
Sub x()
Dim ws As Worksheet, i As Long, j As Long, v As Variant, v2() As Variant
v = Range("A1:D4").Value
ReDim Preserve v2(1 To UBound(v, 1), 1 To UBound(v, 2))
For i = LBound(v, 1) To UBound(v, 1)
If v(i, 1) = 123 Then
j = j + 1
v2(j, 1) = v(i, 1)
v2(j, 2) = v(i, 2)
v2(j, 3) = v(i, 3)
v2(j, 4) = v(i, 4)
End If
Next i
Range("G1").Resize(j, UBound(v2, 2)).Value = v2
End Sub
I have data in Column A that looks like this:
A
B
A
B
B
B
A
B
A
B
Some points:
All A's must have at least one B. All A's have a B, all B's have an A. (it's an accounting system - it requires this).
Any A can have as many B's as needed.
After each A.B[n] combo, we need a C.
The C must be an inserted row. Sorting and Filtering is not allowed (A, B, and C are variables that aren't replaced with alphabetical characters like seen here).
The code should not insert a C above the first A.
Expected output:
A
B
C
A
B
B
B
C
A
B
C
A
B
C
I've already looked at this: Excel: Insert new line every x rows with content according to a pattern
but the pattern is based on a known 27-line insertion. This has no guaranteed pattern in my problem.
Being a forward thinker, I used multiple Do loops.
Sub InsertCs()
Application.ScreenUpdating = False
Const A As String = "A", B As String = "B", C As String = "C"
Dim r As Long, r2 As Long
With Worksheets("Sheet1")
Do
r = r + 1
If .Cells(r, "A").Value = A And .Cells(r, "A").Offset(1).Value = B Then
r2 = r + 1
Do
r2 = r2 + 1
Loop Until Cells(r2, "A").Value = "" Or Cells(r2, "A").Value = A Or Cells(r2, "A").Value = C
If Not Cells(r2).Value = C Then
.Rows(r2).Insert xlDown
.Cells(r2, "A").Value = C
End If
r = r2
End If
Loop Until Cells(r, "A").Value = ""
End With
End Sub
Try
Sub test()
Dim vDB, vR()
Dim A, B, C
Dim i As Long, r As Long, n As Long
A = "A"
B = "B"
C = "C"
vDB = Range("a1").CurrentRegion
r = UBound(vDB, 1)
n = 1
ReDim Preserve vR(1 To n)
vR(1) = vDB(1, 1)
For i = 2 To r
If vDB(i - 1, 1) = B And vDB(i, 1) = A Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = C
End If
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, 1)
Next i
If vR(n) = B Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = C
End If
Range("c1").CurrentRegion.Clear
Range("c1").Resize(n, 1) = WorksheetFunction.Transpose(vR)
End Sub
If you want multi column then
Sub test2()
Dim vDB, vR(), vS()
Dim A, B, C
Dim i As Long, r As Long, n As Long
Dim col As Integer
Dim Ws As Worksheet
A = "A"
B = "B"
C = "C"
vDB = Range("a1").CurrentRegion
r = UBound(vDB, 1)
col = UBound(vDB, 2)
n = 1
ReDim Preserve vR(1 To col, 1 To n)
For j = 1 To col
vR(j, n) = vDB(1, j)
Next j
For i = 2 To r
If vDB(i - 1, 1) = B And vDB(i, 1) = A Then
n = n + 1
ReDim Preserve vR(1 To col, 1 To n)
vR(1, n) = C
End If
n = n + 1
ReDim Preserve vR(1 To col, 1 To n)
For j = 1 To col
vR(j, n) = vDB(i, j)
Next j
Next i
If vR(1, n) = B Then
n = n + 1
ReDim Preserve vR(1 To col, 1 To n)
vR(1, n) = C
End If
Set Ws = Sheets.Add 'Sheets("Result")
With Ws
.Range("a1").CurrentRegion.Clear
.Range("a1").Resize(n, col) = WorksheetFunction.Transpose(vR)
End With
End Sub
1. All A's must have at least one B.
Since all A's must have at least one B, your logic seems to boil down to: If current cell is not B and cell directly above is B then insert row and paste C.
Option Explicit
Sub Macro1()
Dim i As Long
Dim a As Variant, b As Variant, c As Variant
a = "A"
b = "B"
c = "C"
With Worksheets("sheet3")
For i = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 To 3 Step -1
Select Case .Cells(i - 1, "A").Value2
Case b
If .Cells(i, "A").Value2 <> b Then
.Rows(i).Insert
.Cells(i, "A") = c
End If
End Select
Next i
End With
End Sub
Sub MultipleSearch()
Dim rng As Range
Dim cll As Range
Dim lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A1:A" & lrow)
Cells(lrow + 1, 1) = "C"
For i = rng.Cells.Count To 2 Step -1
If rng.Item(i) = "A" Then
Rows(i).Insert
Cells(i, 1) = "C"
End If
Next
End Sub
Try this simple code. It will loop from the last cell in column A and if there is a variable varA then varB, it will insert a row and add varC. Assign your variables as needed.
Dim varA As Variant, varB As Variant, varC As Variant
Dim Rng As Range, i As Long, lRow As Long
varA = "A"
varB = "B"
varC = "C"
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lRow To 2 Step -1
If Cells(i, 1).Value = varB And Cells(i, 1).Offset(-1).Value = varA Then
Cells(i, 1).Offset(1).EntireRow.Insert
Cells(i, 1).Offset(1).Value = varC
End If
Next i
Using Find and some do loops is a way to do it...
Sub InsertC()
Application.ScreenUpdating = False
Dim Data As Range: Set Data = Worksheets("Sheet1").Range("A:A")
Dim FirstCell As Range: Set FirstCell = Data.Find("A", LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, SearchOrder:=xlByRows)
Dim NextCell As Range, ACell As Range: Set ACell = FirstCell
If Not ACell Is Nothing Then
Do
Set NextCell = ACell
Do While NextCell.Offset(1, 0) = "B"
Set NextCell = NextCell.Offset(1, 0)
Loop
If Not ACell = NextCell Then
NextCell.Offset(1, 0).Insert Shift:=xlDown
NextCell.Offset(1, 0) = "C"
End If
Set ACell = Data.Find("A", After:=NextCell, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, SearchOrder:=xlByRows)
Loop While ACell.Address <> FirstCell.Address
End If
Application.ScreenUpdating = True
End Sub
Column A contains the labels or outcome value, Columns B-N contain varying lengths of comma separated values, but range for each column is the same (i.e., 1-64). The goal is to covert to a new table with Column A representing the value range (1-64) and Columns B-N the labels/outcome from the original table.
A semi-related solution was sought here, but without use of macros.
I will let you to modify this code,
Sub splitThem()
Dim i As Long, j As Long, k As Long, x As Long
x = 1
Sheets.Add.Name = "newsheet"
For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(i, j) <> "" Then
For k = 1 To Len(Cells(i, j)) - Len(Replace(Cells(i, j), ",", "")) + 1
Sheets("newsheet").Cells(x, j) = Cells(i, 1)
x = x + 1
Next k
End If
Next i
x = 1
Next j
End Sub
Try this code.
Sub test()
Dim vDB, vR()
Dim vSplit, v As Variant
Dim Ws As Worksheet
Dim i As Long, n As Long, j As Integer, c As Integer
vDB = Range("a2").CurrentRegion
n = UBound(vDB, 1)
c = UBound(vDB, 2)
ReDim vR(1 To 64, 1 To c)
For i = 1 To 64
vR(i, 1) = i
Next i
For i = 2 To n
For j = 2 To c
vSplit = Split(vDB(i, j), ",")
For Each v In vSplit
vR(v, j) = vDB(i, 1)
Next v
Next j
Next i
Set Ws = Sheets.Add '<~~ replace your sheet : Sheets(2)
With Ws
For i = 1 To c
.Range("b1")(1, i) = "COND" & i
Next i
.Range("a2").Resize(64, c) = vR
End With
End Sub