Split cells and insert in a new row - excel

My data includes headers. In column C, the cells sometimes contain "/" or ",". The goal is to split these cells and insert a new row underneath with every sub-string.
INPUT
OUTPUT
With the code below I have been able to replace all "," with "/". Split the cell in column C by the "/" delimiter and paste underneath. I have not been able to copy and paste the contents of the row underneath with every element in the split function array. It also seems to be pasting the split values beginning in cell C2 every time.
Sub SuspenseReport()
Dim SearchCell As Variant
Dim i As Integer
Dim cell As Range
Application.ScreenUpdating = False
Set Rng = Application.Range("C2:C1000") '*Change Last Row Value Here
vLr = ActiveCell.SpecialCells(xlLastCell).Row
For Each cell In Rng
cell = Replace(cell, ",", "/")
If InStr(1, cell, "/") <> 0 Then
SearchCell = Split(cell, "/")
For i = 0 To UBound(SearchCell)
Cells(i + 2, 2).Value = SearchCell(i)
Next i
End If
Next cell
Application.ScreenUpdating = True
End Sub

When inserting or deleting rows always work from the bottom up. To retain the order of the split value, work from last to first.
Option Explicit
Sub splitSlash()
Dim tmp As Variant, i As Long, j As Long
With Worksheets("sheet1")
.Columns("C").Replace what:=Chr(44), replacement:=Chr(47), lookat:=xlPart
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
tmp = Split(.Cells(i, "C").Value2 & Chr(47), Chr(47))
For j = UBound(tmp) - 1 To LBound(tmp) + 1 Step -1
.Cells(i + 1, "A").EntireRow.Insert
.Cells(i + 1, "A") = .Cells(i, "A").Value2
.Cells(i + 1, "B") = .Cells(i, "B").Value2
.Cells(i + 1, "C") = tmp(j)
Next j
.Cells(i, "C") = tmp(j)
Next i
End With
End Sub

Related

Sum Values based on Duplicates - VBA

I am looking for a VBA solution to be able to:
Look for duplicated values in column "A" and format. (Possible with the code below)
With each subsequent duplicate found, the code should sum all the values from Columns "J" through "N" on the first value and fill the duplicated cell black (help)
Sub CombineDuplicates()
Dim Cell As Variant
Dim PList As Range
lRow = Worksheets("Material Planning").Cells(Rows.Count, 1).End(xlUp).Row
Set PList = Worksheets("Material Planning").Range("A4:A" & lRow)
For Each Cell In PList
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(PList, Cell) > 1 Then
'Highlight duplicate values in red color
cRow = Cell.Row
Range("A" & cRow & ":R" & cRow).Interior.Color = RGB(0, 0, 0)
Else
Cell.Interior.Pattern = xlNone
End If
Next
End Sub
Please see the picture for reference. Top is unfiltered data and the bottom is how it should look after the macro runs. Please let me know if you need any more information. Thanks in advance!
This uses a dictionary to detect duplicates and a class to keep your data organized
Place this piece inside of a class module:
Option Explicit
Private data As datasum
Private prow As Long
Private ptargetsheet As Worksheet
Private Type datasum
thirtyday As Long
threemonth As Long
expectedusage As Double
ordertarget As Double
stock As Long
avgdayleft As Long
dayleft As Long
pending As Long
End Type
Sub initialize(targetsheet As Worksheet, row As Long)
Set ptargetsheet = targetsheet
prow = row
End Sub
Sub addData(dataArray As Variant)
data.thirtyday = data.thirtyday + dataArray(1, 1)
data.threemonth = data.threemonth + dataArray(1, 2)
data.expectedusage = data.expectedusage + dataArray(1, 3)
data.ordertarget = data.ordertarget + dataArray(1, 4)
data.stock = data.stock + dataArray(1, 5)
data.avgdayleft = data.avgdayleft + dataArray(1, 6)
data.dayleft = data.dayleft + dataArray(1, 8)
data.pending = data.pending + dataArray(1, 9)
End Sub
Sub placeData()
With ptargetsheet
.Cells(prow, 6).Value = data.thirtyday
.Cells(prow, 7).Value = data.threemonth
.Cells(prow, 8).Value = data.expectedusage
.Cells(prow, 9).Value = data.ordertarget
.Cells(prow, 10).Value = data.stock
.Cells(prow, 11).Value = data.avgdayleft
.Cells(prow, 13).Value = data.dayleft
.Cells(prow, 14).Value = data.pending
End With
End Sub
And this piece in either your sheet module or a regular module:
Option Explicit
Sub CombineDuplicates()
Dim i As Long
Dim lRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim data As DataClass
With Sheets("Material Planning")
lRow = .Cells(.Rows.Count, 1).End(xlUp).row
For i = 4 To lRow
If Not dict.exists(.Cells(i, 1).Value) Then
Set data = New DataClass
data.initialize Sheets("Material Planning"), i
data.addData .Range(.Cells(i, 6), .Cells(i, 14)).Value
dict.Add .Cells(i, 1).Value, data
Else
dict(.Cells(i, 1).Value).addData .Range(.Cells(i, 6), .Cells(i, 14)).Value
dict(.Cells(i, 1).Value).placeData
.Range(.Cells(i, 1), .Cells(i, 14)).Interior.Color = RGB(0, 0, 0)
End If
Next i
End With
End Sub
This would be a simple, but probably not the fastest way of doing it:
Sub CombineDuplicates()
Dim Cell As Variant, PList As Range
Dim i As Long, j As Long, a As Long
Dim k(7) As Long
LRow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To LRow
Erase k
If Not Range("A" & i).Interior.Color = RGB(0, 0, 0) Then
For j = i + 1 To LRow
If Range("A" & i).Value = Range("A" & j).Value Then
For a = 0 To 7
k(a) = k(a) + Cells(j, a + 2)
Next a
Range("A" & j & ":N" & j).Interior.Color = RGB(0, 0, 0)
End If
Next j
For a = 0 To 7
Cells(i, a + 2) = Cells(i, a + 2) + k(a)
Next a
End If
Next i
End Sub
Essentially, for each row that isn't black (to avoid unnessecary calculaitons) we loop the rest of the range to look for duplicats. Add the values in the array k and keep looking.
Then we end the subloop by adding the number from the array to the current row, and keep going.
Should probably add something to clear the interior formatting first, for subsequent runs.
So after sitting and brainstorming for a while, I figured that I was trying to overcomplicate things. Thanks to your responses it helped me figure out the direction that I wanted to go. This is the current code that I have which is working flawlessly! It is a little slow, but since I am not going to be shifting through thousands of data points, its is manageable.
I tried to insert value added comments in the code to show the process:
Sub CombineDuplicates()
Dim Cell As Variant
Dim PList As Range
Worksheets("Material Planning").Unprotect
Set ws = Worksheets("Material Planning")
'set last row of working range
lRow = Worksheets("Material Planning").Cells(Rows.Count, 1).End(xlUp).Row
'Toggle parameter. If any cells in range are not colored then it will execute the macro to add common values
If Range("A4:A" & lRow).Interior.ColorIndex = xlColorIndexNone Then
For i = 1 To lRow
Application.ScreenUpdating = False
Application.EnableEvents = False
'since all of the "duplicate" values are listed near each oter, I just need to compare them one after another
Fst = ws.Range("A" & i)
Snd = ws.Range("A" & i + 1)
If Snd = Fst Then
'saves the Formula from the cell but just adds the value from the current cell to the next one
'this way even if there are more than 2 duplicates, the sum will continue on to the next cell
ws.Range("F" & i + 1).Formula = ws.Range("F" & i + 1).Formula & "+" & ws.Range("F" & i).Value
ws.Range("G" & i + 1).Formula = ws.Range("G" & i + 1).Formula & "+" & ws.Range("G" & i).Value
ws.Range("J" & i + 1).Formula = ws.Range("J" & i + 1).Formula & "+" & ws.Range("J" & i).Value
'The whole Row will be filled black so that it is not considered in the analysis
Range("A" & i & ":U" & i).Interior.Color = RGB(0, 0, 0)
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Else
'if there is already formatting on any cells in column A, this will remove the filled black formatting from all cells in the range
Range("A4:U" & lRow).Interior.Color = xlNone
ws.Range("F4:N" & ws.Cells(Rows.Count, 6).End(xlUp).Row).FillDown
ws.Range("P4:U" & ws.Cells(Rows.Count, 6).End(xlUp).Row).FillDown
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Worksheets("Material Planning").Protect
End Sub
Thank you all for your help and advice on this!
Excel has a built-in dedup function. Can you not programmatically copy the 'Simple Description' column at the top to the area underneath, run the dedup on the range containing the copy, then add sumifs to the remaining columns?
The code below creates the bottom table from the top table shown in the picture.
Sub Dedup()
Range("A1:A9").Copy
Range("A12").PasteSpecial
Range("B1:E1").Copy
Range("B12").PasteSpecial
Range("A13:A20").RemoveDuplicates Columns:=1
Range("B13").Formula = "=SUMIF($A$2:$A$9,$A13,B$2:B$9)"
Range("B13").Copy Destination:=Range("B13:E17")
End Sub
Of course, this doesn't maintain the structure with the black rows, but I haven't understood why you need that anyway, since you still have the original table.
And you'll want to do something a little more sophisticated about identifying the correct ranges, particularly for the copied table and when copying the sumif formula from the first cell to the last cell in the range that results from the deduplication. I've kept it simple here for expediency.
Edit: If you want the bottom table to reflect the structure of the original table, you could do a countif on each of the rows in the copy and insert the requisit number of rows that that gives you, and make the new rows black.
Paste Special xlPasteSpecialOperationAdd
This is a slow solution but may be easily understood.
It loops through the cells in column A and uses Application.Match to find the index (position) of the first occurrence. If it is not the same then it colors the row and uses PasteSpecial with xlPasteSpecialOperationAdd to add the found values to the values defined by the index.
Application.ScreenUpdating will speed up the code hiding the on-going 'worksheet dance'.
The Code
Option Explicit
Sub CombineDuplicates()
Dim ws As Worksheet
Dim PList As Range
Dim Cell As Range
Dim ColsAll As Range
Dim Cols1 As Range
Dim Cols2 As Range
Dim cIndex As Variant
Dim lRow As Long
Dim cRow As Long
Set ws = Worksheets("Material Planning")
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set PList = ws.Range("A4:A" & lRow)
Set ColsAll = ws.Columns("A:N")
Set Cols1 = ws.Columns("F:K")
Set Cols2 = ws.Columns("M:N")
Application.ScreenUpdating = False
For Each Cell In PList.Cells
cRow = Cell.Row
cIndex = Application.Match(Cell.Value, PList, 0) + 3
If cIndex < cRow Then
ColsAll.Rows(cRow).Interior.Color = RGB(0, 0, 0)
Cols1.Rows(cRow).Copy
Cols1.Rows(cIndex) _
.PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
Cols2.Rows(cRow).Copy
Cols2.Rows(cIndex) _
.PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
Else
ColsAll.Rows(cRow).Interior.Pattern = xlNone
End If
Next
Application.CutCopyMode = False
ws.Range("A3").Select
Application.ScreenUpdating = True
End Sub
Try this code, please. It should be very fast, using arrays and working only in memory and does not need to color anything. The processing result, meaning only the unique values with the necessary sum per each column will be dropped on a new sheet added after the processed one:
Sub CombineDuplicates()
`It needs a reference to 'Microsoft Scripting Runtime'
Dim LROW As Long, arrA, arr, arrR(4), arrF, dict As New Scripting.Dictionary
Dim sh As Worksheet, resSh As Worksheet, i As Long, j As Long, arrFin
Set sh = Worksheets("Material Planning")
LROW = sh.cells(rows.Count, 1).End(xlUp).row
arrA = sh.Range("A4:A" & LROW).value
arr = sh.Range("J4:N" & LROW).value
For i = 1 To UBound(arrA)
If Not dict.Exists(arrA(i, 1)) Then
For j = 0 To 4
arrR(j) = arr(i, j + 1)
Next j
dict.Add arrA(i, 1), arrR
Else
For j = 0 To 4
arrR(j) = dict(arrA(i, 1))(j) + arr(i, j + 1)
Next j
dict(arrA(i, 1)) = arrR
End If
Next i
ReDim arrFin(1 To dict.Count, 1 To 5)
ReDim arrF(1 To dict.Count, 1 To 1)
For i = 0 To dict.Count - 1
arrF(i + 1, 1) = dict.Keys(i)
For j = 0 To 4
arrFin(i + 1, j + 1) = dict.items(i)(j)
Next
Next i
Set resSh = Worksheets.Add(After:=sh) 'add a new sheet aftere the active one and drop the array at once
resSh.Range("A2").Resize(UBound(arrF), 1).value = arrF
resSh.Range("J2").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
This approach will allow running the code as many times you need, after eventual updates or just in case. Otherwise, it will return double dates each next time...
If you have a problem with adding the necessary reference, please run the next code before the one able to process your data:
Sub addScrRunTimeRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub
Edited:
If you insist to keep all the range, and making black the interior of duplicates, you can try the next code, also very fast. It will also return in a newly created sheet, but only for testing reason. If it does what you want, the code can be easily adapted to overwrite the existing range of the active sheet:
Sub CombineDuplicatesKeepAll()
Dim LROW As Long, arrA, arrR(14), arrF, dict As New Scripting.Dictionary
Dim sh As Worksheet, resSh As Worksheet, i As Long, j As Long, arrFin, firstR As Long
Dim rngCol As Range, k As Long
Set sh = Worksheets("Material Planning")
LROW = sh.cells(rows.Count, 1).End(xlUp).row
firstR = 4 'first row of the range to be processed
arrA = sh.Range("A" & firstR & ":N" & LROW).value 'place the range to be processed in an array
ReDim arrFin(1 To UBound(arrA), 1 To UBound(arrA, 2)) 'set the final array at the same dimensions
For i = 1 To UBound(arrA) 'iterate between the array elements
If Not dict.Exists(arrA(i, 1)) Then 'if not a dictionary key as value in column A:A (array column 1):
arrR(0) = sh.Range("A" & i + firstR - 1).Address 'place the cell address like forst dictionary item array element
arrR(1) = i 'the array second element will be the array row (to update it later)
arrFin(i, 1) = arrA(i, 1) 'first element of the final array, on i row will be the first column value
For j = 2 To 14
arrR(j) = arrA(i, j) 'input the rest of the row values in the array to be the dictionary item
arrFin(i, j) = arrA(i, j) 'place the same values in the final array
Next j
dict.Add arrA(i, 1), arrR 'add the array built above like dictionary item
Else
arrR(0) = dict(arrA(i, 1))(0) 'keep the same call address like the first element of the array to be input as item
arrFin(i, 1) = arrA(i, 1) 'place the value in column A:A in the first column of the final array
arrR(1) = dict(arrA(i, 1))(1) 'keep the row of the first dictionary key occurrence
For j = 2 To 14 'fill the array with the values of all row columns
If j <= 9 Then 'for first 9 columns keep their value
arrR(j) = dict(arrA(i, 1))(j)
Else 'for the rest (J to N) add the existing value (in dictionary) to the cells value
arrR(j) = dict(arrA(i, 1))(j) + arrA(i, j)
End If
arrFin(i, j) = arrA(i, j) 'fill the final array with the row data
Next j
dict(arrA(i, 1)) = arrR 'place the array like dictionary item
If rngCol Is Nothing Then 'if range to be colored does not exist, create it:
Set rngCol = sh.Range("A" & i + firstR - 1 & ":N" & i + firstR - 1)
Else 'if it exists, make a Union between existing and the new one:
Set rngCol = Union(rngCol, sh.Range("A" & i + firstR - 1 & ":N" & i + firstR - 1))
End If
End If
Next i
'adapt te final array rows which used to be the first occurrence of the same dictionary key:
For i = 0 To dict.Count - 1
k = dict.items(i)(1) 'extract the previously memorized row to be updated
For j = 2 To 14 'adapt the row content, for the row range equivalent columns
arrFin(k, j) = dict.items(i)(j)
Next
Next i
'just for testing, paste the result in a new added sheet.
'If everything OK, the code can drop the value in the active sheet
Set resSh = Worksheets.Add(After:=sh)
'drop the array content at once:
resSh.Range("A4").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
If Not resSh Is Nothing Then _
resSh.Range(rngCol.Address).Interior.Color = vbBlack 'color the interior of the next occurrences
End Sub
I tried commenting the code lines, in a way to be easily understood. If something unclear, do not hesitate to ask for clarifications.
Please, send some feedback after testing it.

Combine duplicate rows and sum the values using dictionary

I have a table as shown below,based on yellow highlighted column i need to sum green highlighted columns.
Expected output is here:
I have done it using the below code …
Sub test()
lrow = ActiveSheet.Cells(ActiveSheet.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A2:A" & lrow)
For Each cell In Rng
If Not IsEmpty(cell) Then
a = cell
b = cell.Offset(0, 1)
c = cell.Offset(0, 5)
r = cell.Row
cnt = Application.WorksheetFunction.CountIf(Rng, cell)
d = 0
For i = 1 To cnt
If Cells(r + i, 1) = a And Cells(r + i, 2) = b And Cells(r + i, 6) Then
Cells(r, 7) = Cells(r + i, 7) + Cells(r, 7)
Cells(r, 8) = Cells(r + i, 8) + Cells(r, 8)
d = d + 1
End If
Next
If d > 0 Then Range(Cells(r + 1, 1).Address, Cells(r + d, 1).Address).EntireRow.Delete
End If
Next
End Sub
I want to do it using scripting dictionary, which is new for me. Since I'm a beginner, I'm unable to modify the below example code found in net!!
Got it from here
Sub MG02Sep59()
Dim Rng As Range, Dn As Range, n As Long, nRng As Range
Set Rng = Range(Range("A2"), Range("A" & 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
Can anyone help me out? with some notes if possible.
this is how I would do it:
Option Explicit
Sub Test()
Dim ws As Worksheet
Dim arrData As Variant
Dim i As Long, ConcatenateStr As String, Sum1 As Currency, Sum2 As Currency
Dim DictSum1 As Scripting.Dictionary 'You need the Microsoft Scripting Runtime reference for this to work
Dim DictSum2 As Scripting.Dictionary
Set ws = ThisWorkbook.Sheets("SheetName") 'Change this to fit your sheet name
Set DictSum1 = New Scripting.Dictionary 'This is how you initialize your dictionary
Set DictSum2 = New Scripting.Dictionary
'Store everything on your sheet into the array
arrData = ws.UsedRange.Value 'this will get from A1 till ctrl+end cell I'd delete rows and columns that are blank
'Loop through the array to fill the dictionary
For i = 2 To UBound(arrData) '2 because row 1 are headers, UBound is the function to get the last item of your array like .count
If arrData(i, 1) = vbNullString Then Exit For 'this will end the loop once finding an empty value on column A
ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6) 'this is to work cleaner, each number is the number of the column concatenated
Sum1 = arrData(i, 7) 'column Sum 1
Sum2 = arrData(i, 8) 'column Sum 2
If Not DictSum1.Exists(ConcatenateStr) Then 'For the column Sum 1
DictSum1.Add ConcatenateStr, Sum1 'this will add the first item Key = Concatenate String and item = the money value
Else
DictSum1(ConcatenateStr) = DictSum1(ConcatenateStr) + Sum1 'this will sum the existing value on the dictionary + the current value of the loop
End If
If Not DictSum2.Exists(ConcatenateStr) Then 'For the column Sum 2
DictSum2.Add ConcatenateStr, Sum2 'this will add the first item Key = Concatenate String and item = the money value
Else
DictSum2(ConcatenateStr) = DictSum2(ConcatenateStr) + Sum2 'this will sum the existing value on the dictionary + the current value of the loop
End If
Next i
Erase arrData
With ws
.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 6), Header:=xlYes 'Again UsedRange will take everything, Columns as you can see are the ones highlighted in yellow
arrData = .UsedRange.Value 'Store the results of deleting all the duplicates
For i = 2 To UBound(arrData) 'Lets fill the array with the sums
ConcatenateStr = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 6)
arrData(i, 8) = DictSum1(ConcatenateStr)
arrData(i, 9) = DictSum2(ConcatenateStr)
Next i
.UsedRange.Value = arrData 'Paste back the array with all the sums
End With
End Sub
I've commented the code, but to learn more about dictionaries check this awesome tutorial

Issue to delete a line in a FindNext loop

With this code I'm trying to search cells in a column where there is a comma character, and divide it into 2 new cells.
Next I want to Delete the original line, but it seems impossible as the value is used in FindNext operation.
What I have :
Column D Column E
Carrot Vegetable
Apple,Banana Fruit
What I need :
Column D Column E
Carrot Vegetable
Apple Fruit
Banana Fruit
What I've done :
Sub newentry()
'
' newentry Macro
'
Dim line
Dim col
Dim content
With Sheets("Feuil3").Columns("D")
Set c = .Find(",", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Select
line = ActiveCell.Row
col = ActiveCell.Column
content = ActiveCell
category = Cells(line, "E")
Dim Table() As String
Dim i As Integer
'split content in a table
Table = Split(content, ",")
'loop on table
For i = 0 To UBound(Table)
'copy result on next line
Rows(line + 1).Insert
Tableau(i) = Application.WorksheetFunction.Trim(Table(i))
Cells(line + 1, col).Value = Table(i)
Cells(line + 1, "E").Value = category
Next i
Set c = .FindNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
'where/how to do this ?
Rows(c.Row).Delete Shift:=xlUp
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
DoneFinding:
End With
End Sub
How can I delete the line that I just found ?
Thanks.
Say we have data in column D like:
Running this short macro:
Sub Restructure()
Dim N As Long, i As Long, j As Long
Dim arr1, arr2, arr3, a1, s As String
N = Cells(Rows.Count, "D").End(xlUp).Row
j = 1
arr1 = Range("D1:D" & N)
For Each a1 In arr1
s = Mid(a1, 2, Len(a1) - 2)
If InStr(s, ",") = 0 Then
Cells(j, "E").Value = "[" & s & "]"
j = j + 1
Else
arr2 = Split(s, ",")
For Each a2 In arr2
Cells(j, "E").Value = "[" & a2 & "]"
j = j + 1
Next a2
End If
Next a1
End Sub
will produce this in column E:
NOTE:
The original data is not disturbed.
insert as many lines as needed minus one below the found cell,
then simply write needed data including found cell row
don't rely on any ActiveCell, just use the c range object you found
Sub newentry()
'
' newentry Macro
'
Dim content As String, Category As String
Dim c As Range
Dim Table() As String
With Sheets("Feuil3").Columns("D")
Set c = .Find(",", LookIn:=xlValues)
If Not c Is Nothing Then
Do
content = c
Category = c.Offset(, 1).Value2
'split content in a table
Table = Split(content, ",")
c.Offset(1).EntireRow.Resize(UBound(Table)).Insert ' insert as many rows needed minus one below the found cell
c.Resize(UBound(Table) + 1).Value = Application.Transpose(Table) ' write contents in as many cells as needed, including the found one
c.Offset(, 1).Resize(UBound(Table) + 1).Value = Array(Category, Category) ' write category in as many cells as needed one column to the right of found one
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
End With
End Sub
Try this code
Sub Test()
Dim a, b, x, i As Long, j As Long, k As Long
a = Range("D1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim b(1 To UBound(a) * 3, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
If InStr(a(i, 1), ",") > 0 Then
x = Split(a(i, 1), ",")
For j = LBound(x) To UBound(x)
k = k + 1
b(k, 1) = Trim(x(j))
b(k, 2) = a(i, 2)
Next j
Else
k = k + 1
b(k, 1) = a(i, 1)
b(k, 2) = a(i, 2)
End If
Next i
Columns("D:E").ClearContents
Range("D1").Resize(k, UBound(b, 2)).Value = b
End Sub

Adding Prefix from cell value on row

I'm creating a macro loop that takes the value from column A and adds it as a prefix to the rest of the cells after column D on that row. When it reaches an empty cell, it then goes to the next row and repeats the process until column A cell is empty. I have used this code which works on the first row, but I can't seem to get it to loop to the other rows.
Sub FLOC
Dim I as Integer
Dim j as Integer
I=4
j=1
'Check that Column A is not empty to stop the Loop
While Not IsEmpty(Cells(j, 1))
If Not IsEmpty(Cells(j,i)) Then
'Select Column D in that row
Cells(j, i).Select
'Add the prefix from Column A to the rest of the Cells on the row
ActiveCell.Value = Cells(1, j).Value & ActiveCell.Value
i = i + 1
'When a empty cell is reached move the ActiveCell to next row, Column D.
Else
i = 4
j = j + 1
Endif
Wend
Sub End
Any help on the right path would be appreciated.
Thanks for the help I solved this with
Sub FLO2 ()
Dim i As Double
Dim j As Double
Dim FLOC As String
j = 1
i = 4
FLOC = Cells(j, 1)
While Not IsEmpty(FLOC)
If Not IsEmpty(Cells(j, i)) Then
Cells(j, i).Select
ActiveCell.Value = Cells(j, 1).Value & ActiveCell.Value
i = i + 1
Else
i = 4
j = j + 1
End If
Wend
Sub End

Excel VBA: How to transform this kind of cells?

I am not sure if the title is correct. Please correct me if you have a better idea.
Here is my problem: Please see the picture.
This excel sheet contains only one column, let's say ColumnA. In ColumnA there are some cells repeat themselvs in the continued cells twice or three times (or even more).
I want to have the excel sheet transformed according to those repeated cells. For those items which repeat three times or more, keep only two of them.
[Shown in the right part of the picture. There are three Bs originally, target is just keep two Bs and delete the rest Bs.]
It's a very difficult task for me. To make it easier, it's no need to delete the empty rows after transformation.
Any kind of help will be highly appreciated. Thanks!
#
Update:
Please see the picture. Please dont delete the items if they show again...
EDITED - SEE BELOW Try this. Data is assumed to be in "Sheet1", and ordered data is written to "Results". I named your repeted data (A, B, C, etc) as sMarker, and values in between as sInsideTheMarker. If markers are not consecutive, the code will fail.
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 2
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = k + 1
a = 2
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, 1).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Results").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
EDITION: If you want results in the same sheet ("Sheet1"), and keep the empty rows for results to look exactly as your question, try the following
Private Sub ReOrderData()
Dim lLastRow As Long
Dim i As Integer
Dim a As Integer
Dim j As Integer
Dim sMarker As String
Dim sInsideTheMarker As String
'Get number of rows with data:
lLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
j = 0
k = 1
a = 5
'Scan all rows with data:
For i = 1 To lLastRow
If (Worksheets("Sheet1").Cells(i + 1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value) Then 'If two consecutive cells holds the same value
j = j + 1
If j = 1 Then
k = i
a = 5
sMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, 4).Value = sMarker
End If
Else 'If not same values in consecutive cells
sInsideTheMarker = Worksheets("Sheet1").Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, a).Value = sInsideTheMarker
a = a + 1
j = 0
End If
Next i
End Sub
If you can delete the values that have more than two counts, then I suggest that this might work:
Sub count_macro()
Dim a As Integer
Dim b As Integer
a = 1
While Cells(a, 1) <> ""
b = WorksheetFunction.CountIf(Range("A1:A1000"), Cells(a, 1))
If b > 2 Then
Cells(a, 1).Delete Shift:=xlUp
End If
b = 0
a = a + 1
Wend
End Sub
This should do it. It takes input in column A starting in Row 2 until it ends, and ignores more than 2 same consecutive values. Then it copies them in sets and pastes them transposed. If your data is in a different column and row, change the sourceRange variable and the i variable accordingly.
Sub SETranspose()
Application.ScreenUpdating = False
Dim sourceRange As range
Dim copyRange As range
Dim myCell As range
Set sourceRange = range("A2", Cells(Rows.count, 1).End(xlUp))
Dim startCell As range
Set startCell = sourceRange(1, 1)
Dim i As Integer
Dim haveTwo As Boolean
haveTwo = True
For i = 3 To Cells(Rows.count, 1).End(xlUp).Row + 1
If Cells(i, 1).Value = startCell.Value Then
If haveTwo Then
range(startCell, Cells(i, 1)).Copy
startCell.Offset(0, 4).PasteSpecial Transpose:=True
Application.CutCopyMode = False
haveTwo = False
End If
End If
'if the letter changes or end of set, then copy the set over
'If LCase(Left(Cells(i, 1).Value, 1)) <> LCase(startCell.Value) Or _
'i = Cells(Rows.count, 1).End(xlUp).Row + 1 Then
If Len(Cells(i, 1).Value) > 1 Then
Set copyRange = Cells(i, 1)
copyRange.Copy
Cells(startCell.Row, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial
Application.CutCopyMode = False
'Set startCell = sourceRange(i - 1, 1)
ElseIf Len(Cells(i, 1).Value) = 1 And Cells(i, 1).Value <> startCell.Value Then
Set startCell = sourceRange(i - 1, 1)
haveTwo = True
End If
Next i
'clear up data
Set sourceRange = Nothing
Set copyRange = Nothing
Set startCell = Nothing
Application.ScreenUpdating = True
End Sub

Resources