Related
On the left is the hypothetical database. On the right is the result I would like to obtain.
I would like to print all of the items of type B, as well as the sum and the count.
I'm stuck and I'm not able to go ahead. Could you please help me out? Thanks.
Private Sub CommandButton1_Click()
Dim dicDistincts As Scripting.Dictionary, _
dicDuplicates As Scripting.Dictionary
Set dicDistincts = New Scripting.Dictionary
Set dicDuplicates = New Scripting.Dictionary
Dim i As Integer
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
If Not dicDistincts.Exists(Cells(i, 2).Value) Then
dicDistincts.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
Else
dicDuplicates.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
End If
End If
Next i
For i = 0 To dicDuplicates.Count - 1
Cells(i + 1, 9).Value = WorksheetFunction.CountIfs(Range("a2:a10"), "B", Range("b2:b10"), dicDistincts.keys(i))
Next i
End Sub
EDIT: I tried with countifs but it return 0 for banana, apple and strawberry
EDIT 2: I corrected the countifs. Now it works.
If you must use dictionaries then you could do this with a single dictionary, storing the counts and quantities as array as the values in the dictionary.
Private Sub CommandButton1_Click()
Dim dic As Scripting.Dictionary
Dim arrData()
Dim i As Long
Dim ky As Variant
Set dic = New Dictionary
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
ky = Cells(i, 2).Value
If Not dic.Exists(ky) Then
arrData = Array(1, Cells(i, 3).Value)
Else
arrData = dic(ky)
arrData = Array(arrData(0) + 1, arrData(1) + Cells(i, 3).Value)
End If
dic(ky) = arrData
End If
Next i
Range("A1:C1").Copy Range("E1:G1")
For i = 0 To dic.Count - 1
Range("E" & i + 2) = dic.Keys(i)
Range("F" & i + 2).Resize(, 2) = dic.Items(i)
Next i
End Sub
Unique Sum and Unique Count with Double Dictionary
Option Explicit
Private Sub CommandButton1_Click()
Dim rg As Range
With Range("A1").CurrentRegion
Set rg = .Resize(.Rows.Count - 1).Offset(1)
End With
Dim Data As Variant: Data = rg.Value
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data, 1)
If Data(i, 1) = "B" Then
cDict(Data(i, 2)) = cDict(Data(i, 2)) + 1 ' Count
sDict(Data(i, 2)) = sDict(Data(i, 2)) + Data(i, 3) ' Sum
End If
Next i
ReDim Data(1 To cDict.Count, 1 To 3)
i = 0
Dim Key As Variant
For Each Key In cDict.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = sDict(Key)
Data(i, 3) = cDict(Key)
Next Key
With Range("E2").Resize(, 3)
.Resize(i).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
End With
End Sub
This should work it uses loops through all bs and addes them if to the other list
Sub countBs()
Dim Bs As Range 'list of the line of all Bs
Dim B As Range 'each indiviual b in the B list
Dim Item As Range 'each indivual item
Dim adder As Range 'resturns nothing if b not fond in times
Set Bs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specifici range or user selected
For Each B In Bs
If B = "B" Then
Set adder = Range("g2", Range("g2").End(xlDown)).Find(B.Offset(0, 1))
If adder Is Nothing Then
If Range("g2") = "" Then
Set Item = Range("g2")
Else
Set Item = Range("g1").End(xlDown).Offset(1, 0)
End If
Item.Resize(1, 2).Value = B.Offset(0, 1).Resize(1, 2).Value
Item.Offset(0, 2) = 1
Else
adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + B.Offset(0, 2).Value
adder.Offset(0, 2).Value = adder.Offset(0, 2).Value + 1
End If
End If
Next B
End Sub
I am new to VBA. i have created triangles which i need to place into the 1st empty row above the given data.
Eg: Please Refer the image.
1) Output after running below code. Yellow marked lines is the row where the output should be shown.
2) actual output it should look like this . (I have edited it manually )
I have created triangle for every data in column c. which i have matched to RANGE(I4:AK4),
but as you can see in image, i am getting output in row 13 in actual it should be in empty row.
It is just my idea: As empty row should be used as the output for the given below data.
For Eg: ROW 20 should be used as output row for given below data in column C (C21,C22,C23)
Please refer the code below as i have tried to create triangle but not able to move to 1st empty row to given below data.
Sub addshape()
Dim lastrow As Long
Dim lastCol As Long
Dim heightCell As Long
Dim widthCell As Long
Dim R As Excel.Range
Dim i As Long
Dim l As Long
Dim s As Shape
With ThisWorkbook.Sheets("Tabelle1")
lastrow = .Cells(Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
For i = 6 To lastrow
If .Cells(i, 3) = " " Then
Else
Set R = .Range(.Cells(4, 9), .Cells(4, lastCol))
If IsEmpty(.Cells(i, 3).Value) = False Then
Set s = ActiveSheet.Shapes.addshape(msoShapeIsoscelesTriangle, 51, 220, 14, 12)
With s
.Name = "triangle" & i
.Rotation = 180
.TextFrame.Characters.Text = Cells(i, 2)
.TextFrame.Characters.Font.Size = 10
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Line.Weight = 1
.Line.ForeColor.RGB = RGB(0, 0, 0)
.TextEffect.Alignment = msoTextEffectAlignmentCentered
.TextFrame.Orientation = msoTextOrientationHorizontal
.TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
.Fill.ForeColor.RGB = RGB(245, 144, 66)
End With
s.Left = 10
l = Application.WorksheetFunction.Match(.Cells(i, 3), R, 0)
l = R(1, l).Left
l = l + (R(1, l).Width / 24)
s.Left = l
End If
End If
Next i
End With
End Sub
Please share your ideas or your codes.
Will be thankful.
What you can do is loop over all your cells backwards to find the first blank cell above the cell you're working from. Then Align the top to the found cell. Concept:
j = i 'Using a new variable to start from i so to not mess up variable i.
Set A = .Range("B1") 'set a range as a blank range will throw an error when used.
Do Until A = "" 'loop until A is assigned a blank cell
j = j - 1 'step -1 to loop backwards
Set A = .Cells(j, 3) 'assign cell to A as one above the last one.
Loop
s.Top = A.Top 'align top of shape to top of found cell.
In your code this would look like so:
Sub addshape()
Dim lastrow As Long
Dim lastCol As Long
Dim heightCell As Long
Dim widthCell As Long
Dim R As Excel.Range
Dim i As Long
Dim j As Long
Dim l As Long
Dim s As Shape
Dim A As Range
With ThisWorkbook.Sheets("Tabelle1")
lastrow = .Cells(Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
For i = 6 To lastrow
If .Cells(i, 3) = " " Then
Else
Set R = .Range(.Cells(4, 9), .Cells(4, lastCol))
If IsEmpty(.Cells(i, 3).Value) = False Then
Set s = ActiveSheet.Shapes.addshape(msoShapeIsoscelesTriangle, 51, 220, 14, 12)
With s
.Name = "triangle" & i
.Rotation = 180
.TextFrame.Characters.Text = Cells(i, 2)
.TextFrame.Characters.Font.Size = 10
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Line.Weight = 1
.Line.ForeColor.RGB = RGB(0, 0, 0)
.TextEffect.Alignment = msoTextEffectAlignmentCentered
.TextFrame.Orientation = msoTextOrientationHorizontal
.TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
.Fill.ForeColor.RGB = RGB(245, 144, 66)
End With
s.Left = 10
l = Application.WorksheetFunction.Match(.Cells(i, 3), R, 0)
l = R(1, l).Left
l = l + (R(1, l).Width / 24)
s.Left = l
j = i
Set A = .Range("B1")
Do Until A = ""
j = j - 1
Set A = .Cells(j, 3)
Loop
s.Top = A.Top
End If
End If
Next i
End With
End Sub
The end goal for my project is that the user will be able to select a value from a ComboBox to fill out a report on a Summary Tab. The report will consist of 3, 3 cell ranges (divided into 3 1x3 ranges on 3 separate worksheets).
I want to find the row with the value the user selected in the ComboBox and then set the 9 cells to the right of that value equal to the values in the range mentioned previously.
I've tried a couple of different ways of doing this, but I'll include the code I most recently worked on below:
Private Sub OKButton1_Click()
Dim userValue, rangeOne, rangeTwo, rangeThree
Dim i As Long
i = 4
userValue = ComboBox1.Value
Set rangeOne = Sheets("Sheet2").Range(Range("F23:H23")
Set rangeTwo = Sheets("Sheet3").Range("F90:H90")
Set rangeThree = Sheets("Sheet4").Range("F17:H17")
While Sheets("Reports").Range(cells(i,1)).Value <> ""
If Sheets("Reports").Range(cells(i, "A")).Value = "userValue" Then
Set Sheets("Reports").Range(Cells(i, "B:E")) = rangeOne
Set Sheets("Reports").Range(Cells(i, "F:I")) = rangeOne
Set Sheets("Reports").Range(Cells(i, "J:M")) = rangeOne
End If
i = i + 1
Wend
Unload UserForm2
End Sub
Any Ideas on how I can improve this or get it working? Currently getting 1004 errors.
Two words of advice when working with excel:
always make variables for each sheet/book you need to work with
Avoid using ranges and objects if you can. It is much easier to iterate over individual cells using an array and a for loop like I did below.
I was a bit confused on exactly what you needed done, so you will need to modify this slightly to fit your ranges/where you want the data to go. If you are confused or need further assistance let me know and I'll update this.
Dim userValue
Dim xrow As Long, ws1 As Worksheet, ws2 As Worksheet, ws3 as Worksheet, ws4 as Worksheet
Dim arrData() as variant
set ws1 = Worksheets("Report")
set ws2 = Worksheets("Sheet2")
set ws3 = Worksheets("Sheet3")
set ws4 = Worksheets("Sheet4")
userValue = ComboBox1.Value
xrow = 1
ws2.activate
'the InStr function checks if the first condition contains the second, and when it does, it returns 1, which in turn triggers the if statement
for x = 1 To ws2.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(0) = ws2.Cells(x, 2).value
arrData(1) = ws2.Cells(x, 3).value
arrData(2) = ws2.Cells(x, 4).value
else:
end if
next x
ws3.activate
for x = 1 To ws3.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(3) = ws3.Cells(x, 2).value
arrData(4) = ws3.Cells(x, 3).value
arrData(5) = ws3.Cells(x, 4).value
else:
end if
next x
ws4.activate
for x = 1 To ws4.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(6) = ws4.Cells(x, 2).value
arrData(7) = ws4.Cells(x, 3).value
arrData(8) = ws4.Cells(x, 4).value
else:
end if
next x
ws1.activate
ws1.Cells(xrow, 1) = userValue
for y = 0 To 8
ws1.Cells(xrow, y+1).value = arrData(y)
next y
xrow = xrow + 1
For x = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If InStr(1, Cells(x, 1), UserValue) > 0 Then
ws1.Cells(x, 2) = ws2.Cells(23, 6).Value
ws1.Cells(x, 3) = ws2.Cells(23, 7).Value
ws1.Cells(x, 4) = ws2.Cells(23, 8).Value
ws1.Cells(x, 6) = ws3.Cells(90, 6).Value
ws1.Cells(x, 7) = ws3.Cells(90, 7).Value
ws1.Cells(x, 8) = ws3.Cells(90, 8).Value
ws1.Cells(x, 10) = ws4.Cells(18, 6).Value
ws1.Cells(x, 11) = ws4.Cells(18, 7).Value
ws1.Cells(x, 12) = ws4.Cells(18, 8).Value
Else:
End If
Next x
The above is what I'm working with now in place of the while loop.
I have the following macro which is so close to what I need. The issue I have is if the data is already in sheet2 it inserts a new line and the same data where as I don't want it duplicated. I have tried a few things but I cant quite get there
'start with sheet 1
Sheets(1).Activate
Dim rowStartSheet1, rowStartSheet2, lastRowSheet1, lastRowSheet2 As Integer
'change this variable if your row doesn't start on 2 as in this example for sheet1 and sheet2
rowStartSheet1 = 2
rowStartSheet2 = 2
'gets you the last row in sheet 1
lastRowSheet1 = Cells(Rows.Count, 1).End(xlUp).Row
'this entire for block is to check if a data row in sheet 1 is in sheet 2 and if so, copy and paste the rest of the data points
For i = rowStartSheet1 To lastRowSheet1
'case 1 where column C matches column A first time around (no duplicates)
'change this variable if sheet 2 starts on a different row
Sheets(2).Activate
lastRowSheet2 = Cells(Rows.Count, 1).End(xlUp).Row
'loops through sheet 2 column A to check if it matches what we want in sheet1 Column C
For ii = rowStartSheet2 To lastRowSheet2
'inputs if found first time around
If Sheets(1).Cells(i, 3) = Cells(ii, 1) And Cells(ii, 7) = "" Then
Cells(ii, 7) = Sheets(1).Cells(i, 1)
Cells(ii, 8) = Sheets(1).Cells(i, 2)
Exit For
'if sheet2 column G already has info in it, create a new row
ElseIf Sheets(1).Cells(i, 3) = Cells(ii, 1) And Cells(ii, 7) <> "" Then
Rows(ii).Select
Selection.Insert Shift:=xlShiftDown
Cells(ii, 1) = Sheets(1).Cells(i, 3)
Cells(ii, 7) = Sheets(1).Cells(i, 1)
Cells(ii, 8) = Sheets(1).Cells(i, 2)
Exit For
End If
Next ii
Next i
End Sub
All help appreciated
SHEET1
SHEET2
In my code below I refer to columns by their name (like "A", "B") instead of their number as you have done. This isn't intended as criticism. On the contrary, I much prefer to use numbers and usually declare them in enumerations. However, I felt that you might find my code more readable with the syntax I chose.
Sub CopyUniqueItems()
' 09 Aug 2017
Const RsFirst As Long = 2
Const RtFirst As Long = 2
Const Lot As Long = 1
Const Part As Long = 2
Const Col As Long = 3
Dim WsS As Worksheet ' S = Source
Dim WsT As Worksheet ' T = Target
Dim Rng As Range
Dim Itm As Variant
Dim Rs As Long, RsLast As Long ' Row / last row in WsS
Dim Rt As Variant, RtLast As Long ' Row / last row in WsT
Set WsS = Worksheets(1) ' { better to call by name
Set WsT = Worksheets(2) ' { like Worksheets("Sheet2")
RsLast = WsS.Cells(WsS.Rows.Count, "C").End(xlUp).Row
Application.ScreenUpdating = False
For Rs = RsFirst To RsLast
With WsS
Itm = .Range(.Cells(Rs, "A"), .Cells(Rs, "C")).Value
End With
With WsT
RtLast = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Columns("A")
Set Rng = .Range(.Cells(RtFirst), .Cells(RtLast))
End With
On Error Resume Next
Rt = Application.Match(Itm(1, Lot), Rng, 0)
If IsError(Rt) Then
' not found
Rt = Application.Max(RtLast + 1, RtFirst)
Else
' exists already
Rt = Rt + RtFirst - 1
Do
If (.Cells(Rt, "G").Value = Itm(1, Part)) And _
(.Cells(Rt, "H").Value = Itm(1, Col)) Then
Rt = 0
Exit Do
Else
Rt = Rt + 1
End If
Loop While .Cells(Rt, "A").Value = Itm(1, Lot)
.Rows(Rt).Insert Shift:=xlShiftDown
End If
If Rt Then
.Cells(Rt, "A").Value = Itm(1, Lot)
.Cells(Rt, "G").Value = Itm(1, Part)
.Cells(Rt, "H").Value = Itm(1, Col)
End If
End With
Next Rs
Application.ScreenUpdating = True
End Sub
BTW, Dim rowStartSheet1, rowStartSheet2, lastRowSheet1, lastRowSheet2 As Integer declares only lastRowSheet2 as integer. All the others are undefined and therefore variants.
Please see the attach image which shows my data and expected data after running the macro,
I would like to split the multi line cell in column B and listed in separate rows and removed text from first space. This values will be called as SESE_ID and should have the RULE from column C for each SESE_ID from the same row.
If there is more than one prefix in column A separated by a comma or space-comma, then repeat the above values for each prefix.
Please someone help me in the macro...
Attached 1st image is the sample source:
And following is the macro:
Sub Complete_sepy_load_macro()
Dim ws, s1, s2 As Worksheet
Dim rw, rw2, rw3, col1, count1, w, x, y, z, cw As Integer
Dim text1 As String
Dim xwalk As String
Dim TOSes As Variant
Application.DisplayAlerts = False
For Each ws In Sheets
If ws.Name = "CMC_SEPY_SE_PYMT" Then Sheets("CMC_SEPY_SE_PYMT").Delete
Next
Application.DisplayAlerts = True
Set s2 = ActiveSheet
g = s2.Name
Sheets.Add.Name = "CMC_SEPY_SE_PYMT"
Set s1 = Sheets("CMC_SEPY_SE_PYMT")
s1.Cells(1, 1) = "SEPY_PFX"
s1.Cells(1, 2) = "SEPY_EFF_DT"
s1.Cells(1, 3) = "SESE_ID"
s1.Cells(1, 4) = "SEPY_TERM_DT"
s1.Cells(1, 5) = "SESE_RULE"
s1.Cells(1, 6) = "SEPY_EXP_CAT"
s1.Cells(1, 7) = "SEPY_ACCT_CAT"
s1.Cells(1, 8) = "SEPY_OPTS"
s1.Cells(1, 9) = "SESE_RULE_ALT"
s1.Cells(1, 10) = "SESE_RULE_ALT_COND"
s1.Cells(1, 11) = "SEPY_LOCK_TOKEN"
s1.Cells(1, 12) = "ATXR_SOURCE_ID"
s1.Range("A:A").NumberFormat = "#"
s1.Range("B:B").NumberFormat = "m/d/yyyy"
s1.Range("C:C").NumberFormat = "#"
s1.Range("D:D").NumberFormat = "m/d/yyyy"
s1.Range("E:E").NumberFormat = "#"
s1.Range("F:F").NumberFormat = "#"
s1.Range("G:G").NumberFormat = "#"
s1.Range("H:H").NumberFormat = "#"
s1.Range("I:I").NumberFormat = "#"
s1.Range("J:J").NumberFormat = "#"
s1.Range("K:K").NumberFormat = "0"
s1.Range("L:L").NumberFormat = "m/d/yyyy"
rw2 = 2
x = 1
y = 1
z = 1
'service id column
Do
y = y + 1
Loop Until s2.Cells(1, y) = "Service ID"
'Rule column
Do
w = w + 1
Loop Until Left(s2.Cells(1, w), 4) = "Rule"
'Crosswalk column
Do
cw = cw + 1
Loop Until Left(s2.Cells(1, cw).Value, 9) = "Crosswalk"
'Alt rule column (location derived from rule column)
'counts # of cells between "rule" and "alt rule", used as precedent for rest of "alt rule" cells
ar = w
Do
ar = ar + 1
Loop Until Left(s2.Cells(1, ar).Value, 3) = "Alt"
ar = ar - w
'prefix row
Do
x = x + 1
Loop Until s2.Cells(x, w) ""
'first service id row
Do
z = z + 1
Loop Until s2.Cells(z, y) ""
'change rw = z + 2 to rw = z, was skipping first two rows
For rw = z To s2.Range("a65536").End(xlUp).Row
If s2.Cells(rw, y) "" Then
If InStr(1, s2.Cells(rw, y), Chr(10)) 0 Then
TOSes = Split(s2.Cells(rw, y).Value, Chr(10)) 'Chr(10) is the "new line" character
count1 = 0
Do
If Trim(TOSes(count1)) "" Then
For col1 = w To s2.UsedRange.Columns.Count
If Left(s2.Cells(1, col1), 4) = "Rule" Then
If InStr(1, TOSes(count1), " ") > 0 Then
s1.Cells(rw2, 3) = Trim(Left(TOSes(count1), InStr(1, TOSes(count1), " "))) 'sese
Else
s1.Cells(rw2, 3) = TOSes(count1)
End If
s1.Cells(rw2, 1) = s2.Cells(x, col1) 'prefix
s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
'use crosswalk service id to populate alt rule
If s2.Cells(rw, cw).Value "" Then
If xwalk = "" Then
Match = False
xwalk = Trim(s2.Cells(rw, cw)) & " "
rwcw = z
Do
If InStr(1, s2.Cells(rwcw, y).Value, xwalk, vbTextCompare) > 0 Then
'obtain rule and write to alt rule column of current row
s2.Cells(rw, col1).Offset(0, ar).Value = s2.Cells(rwcw, w).Value
Match = True
End If
rwcw = rwcw + 1
Loop Until Match = True
End If
End If
s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
s1.Cells(rw2, 7) = "TBD" 'cac
s1.Cells(rw2, 13) = s2.Name 'file
rw2 = rw2 + 1
End If
xwalk = ""
Next col1
End If
count1 = count1 + 1
Loop Until count1 = UBound(TOSes) + 1
Else
For col1 = w To s2.UsedRange.Columns.Count
If Left(s2.Cells(1, col1), 4) = "Rule" Then
If InStr(1, s2.Cells(rw, y), " ") > 0 Then
s1.Cells(rw2, 3) = Trim(Left(s2.Cells(rw, y), 4)) 'sese
Else
s1.Cells(rw2, 3) = s2.Cells(rw, y)
End If
s1.Cells(rw2, 1) = s2.Cells(x, col1) 'prefix
s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
s1.Cells(rw2, 7) = "TBD" 'cac
s1.Cells(rw2, 13) = s2.Name 'file
rw2 = rw2 + 1
End If
Next col1
End If
ElseIf s2.Cells(rw, y) = "" And Trim(s2.Cells(rw, w)) "" Then
If Len(s2.Cells(rw, 1)) >= 10 Then
text1 = Left(s2.Cells(rw, 1), 10) & " |row: " & rw 'sese
Else
text1 = s2.Cells(rw, 1) & " row: " & rw 'sese
End If
For col1 = w To s2.UsedRange.Columns.Count
If Left(s2.Cells(1, col1), 4) = "Rule" Then
s1.Cells(rw2, 3) = text1 'sese
s1.Cells(rw2, 3).Interior.ColorIndex = 6
s1.Cells(rw2, 1) = s2.Cells(x, col1) 'prefix
s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
s1.Cells(rw2, 7) = "TBD" 'cac
s1.Cells(rw2, 13) = s2.Name 'file
rw2 = rw2 + 1
End If
Next col1
End If
Next
For rw3 = 2 To s1.UsedRange.Rows.Count
s1.Cells(rw3, 2) = "1/1/2009"
s1.Cells(rw3, 4) = "12/31/9999"
s1.Cells(rw3, 11) = 1
s1.Cells(rw3, 12) = "1/1/1753"
Next rw3
Dim wb As Workbook
Dim wss, wsSepy, wsSID As Worksheet 'SID = Serivce ID Spreadsheet
Dim sepyRow, sepyCol, acctCol, sidSeseCol, sidAcctCol, j As Long
Dim cell As Range
Dim cellRange As Range
Dim topRow As Range
Dim sepySese As String
MsgBox "All set, make sure there is no #N/A in SESE_RULE column"
End Sub
Below image is the output I got:
Problem: If you see the source data, I have SEPY_PFX in column A. I wanted every row to be repeated for each SEPY. Currently my code gave me RULE as SEPY_PFX, I am still working on it BUT it will be glad if someone help me on this quickly, it is already going above my head.
This code will work on the first example you posted to give the output you wanted:
Original Source:
Original Results:
It works by using Class and Collections, creating each entry one at a time, and then putting it together for the results.
I use arrays to collect and output the data, because this will work much faster. In your original you had some font coloring, which I have carried over.
You should be able to adapt it to your real data, but, if you cannot, I suggest you post a "sanitized" copy of your original data, with the correct columns and so forth, on some file sharing web site such as DropBox, OneDrive, etc; and post a link here so we can see the "real stuff"
With regard to the use of classes, please see Chip Pearson's web site
Also, please read the comments in the code for explanations and suggestions.
First insert a Class Module, ReNAME it cOfcCode and paste the code below into it:
'Will need to add properties for the additional columns
Option Explicit
Private pSEPY As String
Private pFontColor As Long
Private pSESE As String
Private pRule As String
Public Property Get SEPY() As String
SEPY = pSEPY
End Property
Public Property Let SEPY(Value As String)
pSEPY = Value
End Property
Public Property Get FontColor() As Long
FontColor = pFontColor
End Property
Public Property Let FontColor(Value As Long)
pFontColor = Value
End Property
Public Property Get Rule() As String
Rule = pRule
End Property
Public Property Let Rule(Value As String)
pRule = Value
End Property
Public Property Get SESE() As String
SESE = pSESE
End Property
Public Property Let SESE(Value As String)
pSESE = Value
End Property
Then, in a regular module:
Option Explicit
Sub ReformatData()
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim rSrc As Range, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim vSEPY As Variant, vSESE As Variant
Dim cOC As cOfcCode
Dim colOC As Collection
Dim lRGB As Long
Dim I As Long, J As Long, K As Long
'Change Sheet references as needed
Set wsSrc = Worksheets("Sheet2")
Set wsRes = Worksheets("Sheet3")
'Assuming Data is in Columns A:C
With wsSrc
Set rSrc = .Range("A1", .Cells(.Rows.Count, "C").End(xlUp))
End With
Set rRes = wsRes.Range("A1")
vSrc = rSrc
Set colOC = New Collection 'Collection of each "to be" row
For I = 2 To UBound(vSrc, 1)
'Split SEPY_PFX into relevant parts
vSEPY = Split(vSrc(I, 1), ",")
For J = 0 To UBound(vSEPY)
'Get the font color from the original cell
With rSrc(I, 1)
lRGB = .Characters(InStr(1, .Value, vSEPY(J), vbTextCompare), 1).Font.Color
End With
'Split SESE_ID into relevant parts
vSESE = Split(vSrc(I, 2), vbLf)
'Iterate through each SESE_ID, picking up the SEPY_PFX, and RULE
For K = 0 To UBound(vSESE)
Set cOC = New cOfcCode
'Will need to adjust for the extra columns
With cOC
.FontColor = lRGB
.Rule = vSrc(I, 3)
.SEPY = vSEPY(J)
.SESE = vSESE(K)
colOC.Add cOC '<-- ADD to the collection
End With
Next K
Next J
Next I
'Put together the Results
ReDim vRes(0 To colOC.Count, 1 To UBound(vSrc, 2))
'Copy the column headings from the source
For I = 1 To UBound(vRes, 2)
vRes(0, I) = vSrc(1, I)
Next I
'Will need to add entries for the other columns
For I = 1 To colOC.Count
With colOC(I)
vRes(I, 1) = .SEPY
vRes(I, 2) = .SESE
vRes(I, 3) = .Rule
End With
Next I
'Clear the results worksheet and write the results
wsRes.Cells.Clear
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
rRes = vRes
'Add the correct font color and format
For I = 1 To colOC.Count
rRes.Rows(I + 1).Font.Color = colOC(I).FontColor
Next I
With rRes.Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
rRes.EntireColumn.AutoFit
End Sub
Make the changes to the Worksheet references in the code (only need to do that at the beginning of the regular module.
Try this first on your original example, so you can see how it works, then add in the extra columns and processing to the Class and the Collection, or post back here with more details
I assume the original data is in worksheet "DATA", and worksheet "Expected Output" which is used to store processed data , exist already.
Your code will be:　Operation of most lines are explained by comments (right of "'")
Sub processData()
Dim oWS As Worksheet, pWS As Worksheet
Dim oRow As Long, pRow As Long
Dim splitMultiLine As String, splitPerfix As String
Dim c As Long, i As Long, j As Long, k As Long
Dim prefixes As Variant, lines As Variant
Dim dataACol As String, dataBCol As String, dataCCol As String
Set oWS = Worksheets("DATA") 'original data
Set pWS = Worksheets("Expected Output") 'processed data
'Copy title row
For c = 1 To 3
pWS.Cells(1, c) = oWS.Cells(1, c)
Next c
oRow = 2 ' row of oWS
pRow = 2 ' row of pWS
With oWS
While (.Cells(oRow, 1) <> "") 'Loop while A colmn has value
dataACol = .Cells(oRow, 1) 'data in A column
dataBCol = .Cells(oRow, 2) 'data in B column
dataCCol = .Cells(oRow, 3) 'data in C colum
prefixes = Split(dataACol, ",") ' split prefixes by comma
lines = Split(dataBCol, Chr(10)) ' split multi lines in a cell by newline (Char(10))
For i = LBound(prefixes) To UBound(prefixes)
For j = LBound(lines) To UBound(lines)
pWS.Cells(pRow, 1) = Trim(prefixes(i)) ' A column of output
k = InStr(lines(j), " ")
pWS.Cells(pRow, 2) = Left(lines(j), k - 1) ' B column of output
pWS.Cells(pRow, 3) = dataCCol ' C column of output
pRow = pRow + 1
Next j
Next i
oRow = oRow + 1
Wend
End With
End Sub