my data is as below:
Sample Data:
A B C Result:
DG M 1 DG M 5
DG M 2 KH M 9
DG M 2 SG C 7
KH M 4 KH M 5
KH M 5 DG M 5
SG C 6
SG C 1
KH M 3
KH M 2
DG M 5
I got 3 column here, and I wish to sum up the value if rows in column A and B is the same with previous row.
Below is the code I refer from other. But the code seem to have only one criteria, I would like to seek a way to add another criteria.Thank you.
Sub MG()
Dim Rng As Range, Dn As Range, n As Double, nRng As Range
Set Rng = Worksheets("sheet1").Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Dn
Else
If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
.Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + Dn.Offset(, 3)
End If
Next
If Not nRng Is Nothing Then nRng.EntireRow.Delete
End With
End Sub
Here's a different approach:
Sub MG()
Dim Rng As Range, n As Double, j As Long
j = 2: Set Rng = Worksheets("sheet1").Range("A2")
Do While Len(Rng) > 0
Do
n = n + Rng.Offset(, 2).Value
Set Rng = Rng.Offset(1)
Loop While Rng.Row = 2 Or Rng.Value = Rng.Offset(-1).Value And Rng.Offset(-1, 1).Value = Rng.Offset(-1, 1).Value
Cells(j, "E") = Rng.Offset(-1).Value
Cells(j, "F") = Rng.Offset(-1, 1).Value
Cells(j, "G") = n
n = 0: j = j + 1
Loop
End Sub
Try this
Sub Test()
Dim a, ws As Worksheet, dic As Object, s As String, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
Set dic = CreateObject("scripting.dictionary")
a = ws.Range("A2:C" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = LBound(a, 1) To UBound(a, 1)
s = a(i, 1) & vbTab & a(i, 2)
If Not dic.Exists(s) Then dic(s) = Array(, , 0)
dic(s) = Array(a(i, 1), a(i, 2), dic(s)(2) + a(i, 3))
Next i
ws.Range("E2").Resize(dic.Count, 3).Value = Application.Transpose(Application.Transpose(dic.items))
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 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
tmpArr(1, j) may be a date or a string. If it is a date then I need to find it in Range(i4:ck4). The dates in this range are formatted as dates. My code below is not finding my dates. What am I doing wrong?
Data is Code in column A which is alphanumeric and may be 3 characters long. Tbk mnth is column B and is a date.
Code Tbk Mnth
BX 1-Oct-06
C7 1-Dec-11
C7 1-Apr-12
LA 1-Feb-15
NJ 1-Mar-15
Dim rng As Range
Dim tmpArr As Variant
Dim Dict As Object, tmpDict As Object
Dim i As Long, j As Long
Dim v, key
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim item As Variant
Dim d As Date
Set Dict = CreateObject("Scripting.Dictionary")
Set ws = Worksheets("Data")
Set ws2 = Worksheets("Plan")
Set ws3 = Worksheets("test")
With ws
Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2))
tmpArr = rng.Value
For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
' Test if value exists in dictionary. If not add and set up the dictionary item
If Not Dict.exists(tmpArr(i, 1)) Then
Set tmpDict = Nothing
Set tmpDict = CreateObject("Scripting.Dictionary")
Dict.Add key:=tmpArr(i, 1), item:=tmpDict
End If
' Set nested dictionary to variable to edit it
Set tmpDict = Nothing
Set tmpDict = Dict(tmpArr(i, 1))
' Test if value exists in nested Dictionary, add if not and initiate counter
If Not tmpDict.exists(tmpArr(i, 2)) Then
tmpDict.Add key:=tmpArr(i, 2), item:=1
Else
' Increment counter if it already exists
tmpDict(tmpArr(i, 2)) = tmpDict(tmpArr(i, 2)) + 1
End If
' Write nested Dictionary back to Main dictionary
Set Dict(tmpArr(i, 1)) = tmpDict
Next i
' Repurpose array for output setting to maximum possible size (helps with speed of code)
ReDim tmpArr(LBound(tmpArr, 2) To UBound(tmpArr, 2), LBound(tmpArr, 1) To UBound(tmpArr, 1))
' Set starting counters for array
i = LBound(tmpArr, 1)
j = LBound(tmpArr, 2)
' Convert dictionary and nested dictionary to flat output
For Each key In Dict
tmpArr(j, i) = key
i = i + 1
For Each v In Dict(key)
tmpArr(j, i) = v
tmpArr(j + 1, i) = Dict(key)(v)
i = i + 1
Next v
Next key
' Reshape array to actual size
ReDim Preserve tmpArr(LBound(tmpArr, 1) To UBound(tmpArr, 1), LBound(tmpArr, 2) To i - 1)
'Change dates less than date in cell 1,9 to overdue and find the row number associated to the code
d = ws.Cells(1, 9).Value
For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
dte = tmpArr(1, j)
If dte < d Then
tmpArr(1, j) = "Overdue"
b = b + tmpArr(2, j)
Else
With ws2.Range("e5:e280")
Set c = .find(tmpArr(1, j), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
tmpArr(2, j) = firstAddress
End If
End With
End If
Next j
For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
l = Len(tmpArr(1, j))
Select Case l
Case Is <= 3
k = j
rw = tmpArr(2, k)
Case 7
With ws2.Cells(rw, 8)
.Value = .Value + tmpArr(2, j)
End With
Case 10
'find column for date numbers
With ws2.Range("I4:CK4")
d = tmpArr(1, j)
Set c = .find(DateValue(Format(CDate(d), "dd/mm/yyyy")), LookIn:=xlValues, LookAt:=xlPart)
Debug.Print d
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
End If
End With
End Select
Next j
'See what tmpArr looks like
With ws3.Cells(2, 5)
Range(.Offset(0, 0), .Cells(UBound(tmpArr, 2), UBound(tmpArr, 1))) = Application.Transpose(tmpArr)
End With
End With
End Sub
You might use : DateValue() if your date d is set as date format in cells then delete CDate() because Cdate() is used to convert String to date
Case 10
With ws2.Range("i4:ck4")
Dim d As Date
d = tmpArr(1, j)
Set c = .find(DateValue(CDate(d)), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
End If
End With
End Select
Next j
So if your cell is as date format maybe use this one :
Case 10
With ws2.Range("i4:ck4")
Dim d As Date
d = tmpArr(1, j)
Set c = .find(DateValue(d), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
End If
End With
End Select
Next j
Edit
Case 10
With ws2.Range("i4:ck4")
Dim d As Date
d = tmpArr(1, j)
Set c = .find(DateValue(Format(CDate(d), "dd/mm/yyyy")), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
End If
End With
End Select
Next j
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