VBA code to concatenate cells based on values in other columns
This is a daily task of mine where I have to take raw data as pictured in Image 1 and I have to sort the data. Usually the data sample I have to go through is around 2000 line items.
I would like to stream line this as best as possible so I want to break down my process into steps.
- I sort the data by Column E ("CE Name"),
- I conditionally format and for duplicates in Column A (Product Serial) and Column E ("CE Name"),
- I look for values not equal to "L101" in Column G ("Cause Code") (I highlight them for visual purposes),
(The Difficult Step) If Column E ("CE Name") values are the same and Column G ("Cause Code") values are not equal to "L101" I separate those values.
Note: this will make two sample data sets
Data sample 1: will be any set or single row that includes an "L101" Value in Column G ("Cause Code").
Data sample 2: will be any set or single row that does not includes an "L101" Value in Column G ("Cause Code").
EX:1 Row 4 and 5 of Image 1, "C-375204" has 2 Column G ("Cause Code") values not equal to L101. This will become a "Data sample 2".
EX:2 Row 8 and 9 of image 1, "C-375306" has Column G ("Cause Code") values of "L101" and "L208" Since there is an "L101" value present it will become a "Data sample 1".
EX:3 Row 12 and 13 of image 1, "C-376157" has 2 Column G ("Cause Code") values of "L101" This will become a "Data sample 1".
Once all data is sorted I concatenate the values in Column B ("Symp") based one the Column E ("CE Name") values separated by commas (",").
EX: Row 4 and 5 of Image 1, "C-375204" will Column B ("Symp") appear as "LM01, LM01" as picture in Image 3 row 24.
Remove extra data to end it final product pictured in Image 3.
Image 1: Raw Data
Image 2: Pairs
Image 3: Final Data
microsoft-excel worksheet-function vba microsoft-excel-2013 microsoft-excel-2016
add a comment |
This is a daily task of mine where I have to take raw data as pictured in Image 1 and I have to sort the data. Usually the data sample I have to go through is around 2000 line items.
I would like to stream line this as best as possible so I want to break down my process into steps.
- I sort the data by Column E ("CE Name"),
- I conditionally format and for duplicates in Column A (Product Serial) and Column E ("CE Name"),
- I look for values not equal to "L101" in Column G ("Cause Code") (I highlight them for visual purposes),
(The Difficult Step) If Column E ("CE Name") values are the same and Column G ("Cause Code") values are not equal to "L101" I separate those values.
Note: this will make two sample data sets
Data sample 1: will be any set or single row that includes an "L101" Value in Column G ("Cause Code").
Data sample 2: will be any set or single row that does not includes an "L101" Value in Column G ("Cause Code").
EX:1 Row 4 and 5 of Image 1, "C-375204" has 2 Column G ("Cause Code") values not equal to L101. This will become a "Data sample 2".
EX:2 Row 8 and 9 of image 1, "C-375306" has Column G ("Cause Code") values of "L101" and "L208" Since there is an "L101" value present it will become a "Data sample 1".
EX:3 Row 12 and 13 of image 1, "C-376157" has 2 Column G ("Cause Code") values of "L101" This will become a "Data sample 1".
Once all data is sorted I concatenate the values in Column B ("Symp") based one the Column E ("CE Name") values separated by commas (",").
EX: Row 4 and 5 of Image 1, "C-375204" will Column B ("Symp") appear as "LM01, LM01" as picture in Image 3 row 24.
Remove extra data to end it final product pictured in Image 3.
Image 1: Raw Data
Image 2: Pairs
Image 3: Final Data
microsoft-excel worksheet-function vba microsoft-excel-2013 microsoft-excel-2016
Interesting, Yes you could record a macro do give you the framework, then generalize it. However, if I understand your needs maybe a pivot table could solve your problem. It won't do the concatenate, but will create the groups I think you are looking for. Maybe that will be sufficient...
– gns100
Jan 31 at 19:30
Unfortunately the concatenated data is the most relevant to the final data presented. i've been sorting the data the "Manual" way for a long time. i've started learning some VBA but this is way out of my current ability.
– Mark
Feb 1 at 1:22
How do you separate the data samples? In the same table separated by an empty line like in image 3? Wouldn't that break if you sort something? Why does LC106855 and LC109164 end up in different samples?
– Christofer Weber
Feb 2 at 18:26
The data samples are separated here by a blank row but its not required. It can be a different sheet I just separate it here by a blank row since its a manual process and I only had the top data set autofiltered when I made this so it would'nt mess up the sorting. you are also correct I made a mistake when I quickly put this data set together. LC109164 should be part of "Data Sample 1" not 2
– Mark
Feb 4 at 19:48
add a comment |
This is a daily task of mine where I have to take raw data as pictured in Image 1 and I have to sort the data. Usually the data sample I have to go through is around 2000 line items.
I would like to stream line this as best as possible so I want to break down my process into steps.
- I sort the data by Column E ("CE Name"),
- I conditionally format and for duplicates in Column A (Product Serial) and Column E ("CE Name"),
- I look for values not equal to "L101" in Column G ("Cause Code") (I highlight them for visual purposes),
(The Difficult Step) If Column E ("CE Name") values are the same and Column G ("Cause Code") values are not equal to "L101" I separate those values.
Note: this will make two sample data sets
Data sample 1: will be any set or single row that includes an "L101" Value in Column G ("Cause Code").
Data sample 2: will be any set or single row that does not includes an "L101" Value in Column G ("Cause Code").
EX:1 Row 4 and 5 of Image 1, "C-375204" has 2 Column G ("Cause Code") values not equal to L101. This will become a "Data sample 2".
EX:2 Row 8 and 9 of image 1, "C-375306" has Column G ("Cause Code") values of "L101" and "L208" Since there is an "L101" value present it will become a "Data sample 1".
EX:3 Row 12 and 13 of image 1, "C-376157" has 2 Column G ("Cause Code") values of "L101" This will become a "Data sample 1".
Once all data is sorted I concatenate the values in Column B ("Symp") based one the Column E ("CE Name") values separated by commas (",").
EX: Row 4 and 5 of Image 1, "C-375204" will Column B ("Symp") appear as "LM01, LM01" as picture in Image 3 row 24.
Remove extra data to end it final product pictured in Image 3.
Image 1: Raw Data
Image 2: Pairs
Image 3: Final Data
microsoft-excel worksheet-function vba microsoft-excel-2013 microsoft-excel-2016
This is a daily task of mine where I have to take raw data as pictured in Image 1 and I have to sort the data. Usually the data sample I have to go through is around 2000 line items.
I would like to stream line this as best as possible so I want to break down my process into steps.
- I sort the data by Column E ("CE Name"),
- I conditionally format and for duplicates in Column A (Product Serial) and Column E ("CE Name"),
- I look for values not equal to "L101" in Column G ("Cause Code") (I highlight them for visual purposes),
(The Difficult Step) If Column E ("CE Name") values are the same and Column G ("Cause Code") values are not equal to "L101" I separate those values.
Note: this will make two sample data sets
Data sample 1: will be any set or single row that includes an "L101" Value in Column G ("Cause Code").
Data sample 2: will be any set or single row that does not includes an "L101" Value in Column G ("Cause Code").
EX:1 Row 4 and 5 of Image 1, "C-375204" has 2 Column G ("Cause Code") values not equal to L101. This will become a "Data sample 2".
EX:2 Row 8 and 9 of image 1, "C-375306" has Column G ("Cause Code") values of "L101" and "L208" Since there is an "L101" value present it will become a "Data sample 1".
EX:3 Row 12 and 13 of image 1, "C-376157" has 2 Column G ("Cause Code") values of "L101" This will become a "Data sample 1".
Once all data is sorted I concatenate the values in Column B ("Symp") based one the Column E ("CE Name") values separated by commas (",").
EX: Row 4 and 5 of Image 1, "C-375204" will Column B ("Symp") appear as "LM01, LM01" as picture in Image 3 row 24.
Remove extra data to end it final product pictured in Image 3.
Image 1: Raw Data
Image 2: Pairs
Image 3: Final Data
microsoft-excel worksheet-function vba microsoft-excel-2013 microsoft-excel-2016
microsoft-excel worksheet-function vba microsoft-excel-2013 microsoft-excel-2016
edited Feb 4 at 1:05
Scott
15.8k113990
15.8k113990
asked Jan 31 at 18:56
MarkMark
134
134
Interesting, Yes you could record a macro do give you the framework, then generalize it. However, if I understand your needs maybe a pivot table could solve your problem. It won't do the concatenate, but will create the groups I think you are looking for. Maybe that will be sufficient...
– gns100
Jan 31 at 19:30
Unfortunately the concatenated data is the most relevant to the final data presented. i've been sorting the data the "Manual" way for a long time. i've started learning some VBA but this is way out of my current ability.
– Mark
Feb 1 at 1:22
How do you separate the data samples? In the same table separated by an empty line like in image 3? Wouldn't that break if you sort something? Why does LC106855 and LC109164 end up in different samples?
– Christofer Weber
Feb 2 at 18:26
The data samples are separated here by a blank row but its not required. It can be a different sheet I just separate it here by a blank row since its a manual process and I only had the top data set autofiltered when I made this so it would'nt mess up the sorting. you are also correct I made a mistake when I quickly put this data set together. LC109164 should be part of "Data Sample 1" not 2
– Mark
Feb 4 at 19:48
add a comment |
Interesting, Yes you could record a macro do give you the framework, then generalize it. However, if I understand your needs maybe a pivot table could solve your problem. It won't do the concatenate, but will create the groups I think you are looking for. Maybe that will be sufficient...
– gns100
Jan 31 at 19:30
Unfortunately the concatenated data is the most relevant to the final data presented. i've been sorting the data the "Manual" way for a long time. i've started learning some VBA but this is way out of my current ability.
– Mark
Feb 1 at 1:22
How do you separate the data samples? In the same table separated by an empty line like in image 3? Wouldn't that break if you sort something? Why does LC106855 and LC109164 end up in different samples?
– Christofer Weber
Feb 2 at 18:26
The data samples are separated here by a blank row but its not required. It can be a different sheet I just separate it here by a blank row since its a manual process and I only had the top data set autofiltered when I made this so it would'nt mess up the sorting. you are also correct I made a mistake when I quickly put this data set together. LC109164 should be part of "Data Sample 1" not 2
– Mark
Feb 4 at 19:48
Interesting, Yes you could record a macro do give you the framework, then generalize it. However, if I understand your needs maybe a pivot table could solve your problem. It won't do the concatenate, but will create the groups I think you are looking for. Maybe that will be sufficient...
– gns100
Jan 31 at 19:30
Interesting, Yes you could record a macro do give you the framework, then generalize it. However, if I understand your needs maybe a pivot table could solve your problem. It won't do the concatenate, but will create the groups I think you are looking for. Maybe that will be sufficient...
– gns100
Jan 31 at 19:30
Unfortunately the concatenated data is the most relevant to the final data presented. i've been sorting the data the "Manual" way for a long time. i've started learning some VBA but this is way out of my current ability.
– Mark
Feb 1 at 1:22
Unfortunately the concatenated data is the most relevant to the final data presented. i've been sorting the data the "Manual" way for a long time. i've started learning some VBA but this is way out of my current ability.
– Mark
Feb 1 at 1:22
How do you separate the data samples? In the same table separated by an empty line like in image 3? Wouldn't that break if you sort something? Why does LC106855 and LC109164 end up in different samples?
– Christofer Weber
Feb 2 at 18:26
How do you separate the data samples? In the same table separated by an empty line like in image 3? Wouldn't that break if you sort something? Why does LC106855 and LC109164 end up in different samples?
– Christofer Weber
Feb 2 at 18:26
The data samples are separated here by a blank row but its not required. It can be a different sheet I just separate it here by a blank row since its a manual process and I only had the top data set autofiltered when I made this so it would'nt mess up the sorting. you are also correct I made a mistake when I quickly put this data set together. LC109164 should be part of "Data Sample 1" not 2
– Mark
Feb 4 at 19:48
The data samples are separated here by a blank row but its not required. It can be a different sheet I just separate it here by a blank row since its a manual process and I only had the top data set autofiltered when I made this so it would'nt mess up the sorting. you are also correct I made a mistake when I quickly put this data set together. LC109164 should be part of "Data Sample 1" not 2
– Mark
Feb 4 at 19:48
add a comment |
2 Answers
2
active
oldest
votes
I didn't quite have time to polish it and there are some shortcuts, but this should do something along the lines of what you are asking.
This code expects your table to be in the top left corner of the sheet that you are running the macro in. It will create two new sheets and dump the data in there.
Sub Sort()
Dim name As String, i As Integer, nameRange As Range, savedRange As Range, firstRange As Range, obj As Variant
'Set "E" to whatever Column contains the "CE Name"
Set nameRange = ActiveSheet.Range(Range("E2"), Range("E65000").End(xlUp))
Set savedRange = Nothing
'Make new sheets for sorted data
If Evaluate("ISREF('" & "Data 1" & "'!A1)") = False Then
Sheets.Add(After:=ActiveSheet).name = "Data 1"
Sheets.Add(After:=ActiveSheet).name = "Data 2"
End If
For Each obj In nameRange
'Make Group
If savedRange Is Nothing Then
Set savedRange = Range(obj.Address)
Set firstRange = Range(obj.Address)
Else
Set savedRange = Range(savedRange.Address, obj.Address)
End If
'Print Group
If Not obj.Offset(1).Value = obj.Value Then
If Not savedRange.Offset(0, 2).Find("L101 - Cycler", LookIn:=xlValues) Is Nothing Then
'Data range 1
Rows(firstRange.Row).Copy
Sheets("Data 1").Range("A1").Insert
Sheets("Data 1").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
Else
'Data Range 2
Rows(firstRange.Row).Copy
Sheets("Data 2").Range("A1").Insert
Sheets("Data 2").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
End If
'reset group
Set savedRange = Nothing
End If
Next obj
End Sub
Function ConcatenateRow(rowRange As Range, joinString As String) As String
Dim x As Variant, temp As String
temp = ""
For Each x In rowRange
temp = temp & x & joinString
Next
ConcatenateRow = Left(temp, Len(temp) - Len(joinString))
End Function
Thank you Christofer I appreciate the code. this is very helpful. I don't have enough reputation to upvote, I have also been working on some code for this I wrote above. if you have the time i would love if you could review it and give some constructive feedback/ Suggestions
– Mark
Feb 19 at 19:59
add a comment |
I appreciate the help from everyone, I have been working tirelessly on this and I learned a lot, so I wanted to share the code I wrote for this. I have included a few references commented in the code I used. also if you have any further suggestions I would love to hear them.
This Code will:
Create a dictionary of user identified cause Values to look out for, and create a dictionary of cause Values with a matching CE-Name.
It will concatenate the Symp that have a matching CE name and identify the concatenated cell by highlighting it as long as the "user identified cause Values" are not present in the Matching CE Cause Dictionary
It will identify the extra (unnecessary Rows) Rows as N/A
It will remove any row with N/A
It will then sort the data by Identified (Colored) Rows
Private Sub Auto_Combine() 'Step 5 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'WIP Auto Combine cells based on Symp value
'******************************************************************************
'Variables
Dim PrevRefCell As String 'Refers to the Complaint Number Column A
Dim CurrRefCell As String 'Refers to the Complaint Number Column A
Dim PrevCombCell As Range
Dim CurrCombCell As Range
Dim PrevSympCell As String
Dim CurrSympCell As String
Dim PrevCausCell As Range
Dim CurrCausCell As Range
Dim FirstFour As String
Dim PrevFirstFour As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Dim i As Long
Dim Flag As Boolean
Dim CauseDict As Object
Set CauseDict = CreateObject("Scripting.Dictionary")
CauseDict.Add "L101", "L101"
CauseDict.Add "X101", "X101"
CauseDict.Add "L304", "L304"
Dim CauseDictItem As Variant
Dim CurCauseDict As Object
Set CurCauseDict = CreateObject("Scripting.Dictionary")
Dim j As Variant
Dim l As Variant
Dim RefDict As Object
Set RefDict = CreateObject("Scripting.Dictionary")
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
'Assign increment cell locations to variables
CurrRefCell = ActiveSheet.Range("A" & CurRRow).Value
CurrSympCell = ActiveSheet.Range("P" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("A" & PrevRow).Value
PrevSympCell = ActiveSheet.Range("P" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, PrevRefCell) > 0 Then ' If A.1
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
' combine Symptom code combos to combo cell in column "O"
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
Set PrevCombCell = ActiveSheet.Range("O" & PrevRow)
CurrCombCell.Value = CurrSympCell & "," & PrevCombCell.Value
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
Set PrevCausCell = ActiveSheet.Range("R" & PrevRow)
' After Combo is made N/A previous combo cell
PrevCombCell.Value = "N/A"
FirstFour = Left(CurrCausCell, 4)
PrevFirstFour = Left(PrevCausCell, 4)
If Not CurCauseDict.Exists(PrevFirstFour) Then
CurCauseDict.Add PrevFirstFour, PrevFirstFour
End If
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
End If
' Look for non "L101" cause codes can highlight CurrCombCell Yellow based on values
i = i - 1
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.1 If Begin
For Each l In CurCauseDict.Keys
If CauseDict.Exists(l) Then
Flag = True
End If
Next
If Flag = True Then
'__________________
Else
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
End If
ColorSKIP: '-----------------------------------------------------------------------------
'Nested Loop A.1.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Else Begin
' if only single line item assign current symp to current comb location
Else 'A.1 Else Begin
CurCauseDict.RemoveAll
i = 0
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
CurrCombCell.Value = CurrSympCell
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
FirstFour = Left(CurrCausCell, 4)
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
On Error Resume Next
End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.2 If Begin
For Each j In CurCauseDict.Keys
If Not CauseDict.Exists(j) Then ' if current "beginning" dict key is in "ending" dict
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
CurCauseDict.RemoveAll
Flag = False
End If
Next
'Nested Loop A.1.2 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End If 'A.1 Else End
'Nested Loop A.1 Else End
'Nested Loop A.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
'For Loop A End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Sub AA2_NA_Data_Sort() 'Step 6 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Variables
Dim PrevRefCell As String
Dim CurrRefCell As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Range("A1").Select
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
CurrRefCell = ActiveSheet.Range("O" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("O" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, "N/A") > 0 Then
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
ActiveSheet.Range("A" & CurRRow).Activate
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
End If
' Else
'Nested Loop A.1 Else End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
End Sub
Sub AA3_Color_Sort() 'Step 7 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Sort by CE Name
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'******************************************************************************
'Sort By Color no fill on top
' Range("A1:U120").Select
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("O:O"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
add a comment |
Your Answer
StackExchange.ready(function() {
var channelOptions = {
tags: "".split(" "),
id: "3"
};
initTagRenderer("".split(" "), "".split(" "), channelOptions);
StackExchange.using("externalEditor", function() {
// Have to fire editor after snippets, if snippets enabled
if (StackExchange.settings.snippets.snippetsEnabled) {
StackExchange.using("snippets", function() {
createEditor();
});
}
else {
createEditor();
}
});
function createEditor() {
StackExchange.prepareEditor({
heartbeatType: 'answer',
autoActivateHeartbeat: false,
convertImagesToLinks: true,
noModals: true,
showLowRepImageUploadWarning: true,
reputationToPostImages: 10,
bindNavPrevention: true,
postfix: "",
imageUploader: {
brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
allowUrls: true
},
onDemand: true,
discardSelector: ".discard-answer"
,immediatelyShowMarkdownHelp:true
});
}
});
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fsuperuser.com%2fquestions%2f1400713%2fvba-code-to-concatenate-cells-based-on-values-in-other-columns%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
2 Answers
2
active
oldest
votes
2 Answers
2
active
oldest
votes
active
oldest
votes
active
oldest
votes
I didn't quite have time to polish it and there are some shortcuts, but this should do something along the lines of what you are asking.
This code expects your table to be in the top left corner of the sheet that you are running the macro in. It will create two new sheets and dump the data in there.
Sub Sort()
Dim name As String, i As Integer, nameRange As Range, savedRange As Range, firstRange As Range, obj As Variant
'Set "E" to whatever Column contains the "CE Name"
Set nameRange = ActiveSheet.Range(Range("E2"), Range("E65000").End(xlUp))
Set savedRange = Nothing
'Make new sheets for sorted data
If Evaluate("ISREF('" & "Data 1" & "'!A1)") = False Then
Sheets.Add(After:=ActiveSheet).name = "Data 1"
Sheets.Add(After:=ActiveSheet).name = "Data 2"
End If
For Each obj In nameRange
'Make Group
If savedRange Is Nothing Then
Set savedRange = Range(obj.Address)
Set firstRange = Range(obj.Address)
Else
Set savedRange = Range(savedRange.Address, obj.Address)
End If
'Print Group
If Not obj.Offset(1).Value = obj.Value Then
If Not savedRange.Offset(0, 2).Find("L101 - Cycler", LookIn:=xlValues) Is Nothing Then
'Data range 1
Rows(firstRange.Row).Copy
Sheets("Data 1").Range("A1").Insert
Sheets("Data 1").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
Else
'Data Range 2
Rows(firstRange.Row).Copy
Sheets("Data 2").Range("A1").Insert
Sheets("Data 2").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
End If
'reset group
Set savedRange = Nothing
End If
Next obj
End Sub
Function ConcatenateRow(rowRange As Range, joinString As String) As String
Dim x As Variant, temp As String
temp = ""
For Each x In rowRange
temp = temp & x & joinString
Next
ConcatenateRow = Left(temp, Len(temp) - Len(joinString))
End Function
Thank you Christofer I appreciate the code. this is very helpful. I don't have enough reputation to upvote, I have also been working on some code for this I wrote above. if you have the time i would love if you could review it and give some constructive feedback/ Suggestions
– Mark
Feb 19 at 19:59
add a comment |
I didn't quite have time to polish it and there are some shortcuts, but this should do something along the lines of what you are asking.
This code expects your table to be in the top left corner of the sheet that you are running the macro in. It will create two new sheets and dump the data in there.
Sub Sort()
Dim name As String, i As Integer, nameRange As Range, savedRange As Range, firstRange As Range, obj As Variant
'Set "E" to whatever Column contains the "CE Name"
Set nameRange = ActiveSheet.Range(Range("E2"), Range("E65000").End(xlUp))
Set savedRange = Nothing
'Make new sheets for sorted data
If Evaluate("ISREF('" & "Data 1" & "'!A1)") = False Then
Sheets.Add(After:=ActiveSheet).name = "Data 1"
Sheets.Add(After:=ActiveSheet).name = "Data 2"
End If
For Each obj In nameRange
'Make Group
If savedRange Is Nothing Then
Set savedRange = Range(obj.Address)
Set firstRange = Range(obj.Address)
Else
Set savedRange = Range(savedRange.Address, obj.Address)
End If
'Print Group
If Not obj.Offset(1).Value = obj.Value Then
If Not savedRange.Offset(0, 2).Find("L101 - Cycler", LookIn:=xlValues) Is Nothing Then
'Data range 1
Rows(firstRange.Row).Copy
Sheets("Data 1").Range("A1").Insert
Sheets("Data 1").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
Else
'Data Range 2
Rows(firstRange.Row).Copy
Sheets("Data 2").Range("A1").Insert
Sheets("Data 2").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
End If
'reset group
Set savedRange = Nothing
End If
Next obj
End Sub
Function ConcatenateRow(rowRange As Range, joinString As String) As String
Dim x As Variant, temp As String
temp = ""
For Each x In rowRange
temp = temp & x & joinString
Next
ConcatenateRow = Left(temp, Len(temp) - Len(joinString))
End Function
Thank you Christofer I appreciate the code. this is very helpful. I don't have enough reputation to upvote, I have also been working on some code for this I wrote above. if you have the time i would love if you could review it and give some constructive feedback/ Suggestions
– Mark
Feb 19 at 19:59
add a comment |
I didn't quite have time to polish it and there are some shortcuts, but this should do something along the lines of what you are asking.
This code expects your table to be in the top left corner of the sheet that you are running the macro in. It will create two new sheets and dump the data in there.
Sub Sort()
Dim name As String, i As Integer, nameRange As Range, savedRange As Range, firstRange As Range, obj As Variant
'Set "E" to whatever Column contains the "CE Name"
Set nameRange = ActiveSheet.Range(Range("E2"), Range("E65000").End(xlUp))
Set savedRange = Nothing
'Make new sheets for sorted data
If Evaluate("ISREF('" & "Data 1" & "'!A1)") = False Then
Sheets.Add(After:=ActiveSheet).name = "Data 1"
Sheets.Add(After:=ActiveSheet).name = "Data 2"
End If
For Each obj In nameRange
'Make Group
If savedRange Is Nothing Then
Set savedRange = Range(obj.Address)
Set firstRange = Range(obj.Address)
Else
Set savedRange = Range(savedRange.Address, obj.Address)
End If
'Print Group
If Not obj.Offset(1).Value = obj.Value Then
If Not savedRange.Offset(0, 2).Find("L101 - Cycler", LookIn:=xlValues) Is Nothing Then
'Data range 1
Rows(firstRange.Row).Copy
Sheets("Data 1").Range("A1").Insert
Sheets("Data 1").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
Else
'Data Range 2
Rows(firstRange.Row).Copy
Sheets("Data 2").Range("A1").Insert
Sheets("Data 2").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
End If
'reset group
Set savedRange = Nothing
End If
Next obj
End Sub
Function ConcatenateRow(rowRange As Range, joinString As String) As String
Dim x As Variant, temp As String
temp = ""
For Each x In rowRange
temp = temp & x & joinString
Next
ConcatenateRow = Left(temp, Len(temp) - Len(joinString))
End Function
I didn't quite have time to polish it and there are some shortcuts, but this should do something along the lines of what you are asking.
This code expects your table to be in the top left corner of the sheet that you are running the macro in. It will create two new sheets and dump the data in there.
Sub Sort()
Dim name As String, i As Integer, nameRange As Range, savedRange As Range, firstRange As Range, obj As Variant
'Set "E" to whatever Column contains the "CE Name"
Set nameRange = ActiveSheet.Range(Range("E2"), Range("E65000").End(xlUp))
Set savedRange = Nothing
'Make new sheets for sorted data
If Evaluate("ISREF('" & "Data 1" & "'!A1)") = False Then
Sheets.Add(After:=ActiveSheet).name = "Data 1"
Sheets.Add(After:=ActiveSheet).name = "Data 2"
End If
For Each obj In nameRange
'Make Group
If savedRange Is Nothing Then
Set savedRange = Range(obj.Address)
Set firstRange = Range(obj.Address)
Else
Set savedRange = Range(savedRange.Address, obj.Address)
End If
'Print Group
If Not obj.Offset(1).Value = obj.Value Then
If Not savedRange.Offset(0, 2).Find("L101 - Cycler", LookIn:=xlValues) Is Nothing Then
'Data range 1
Rows(firstRange.Row).Copy
Sheets("Data 1").Range("A1").Insert
Sheets("Data 1").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
Else
'Data Range 2
Rows(firstRange.Row).Copy
Sheets("Data 2").Range("A1").Insert
Sheets("Data 2").Range("B1").Value = ConcatenateRow(savedRange.Offset(0, -3), ",")
End If
'reset group
Set savedRange = Nothing
End If
Next obj
End Sub
Function ConcatenateRow(rowRange As Range, joinString As String) As String
Dim x As Variant, temp As String
temp = ""
For Each x In rowRange
temp = temp & x & joinString
Next
ConcatenateRow = Left(temp, Len(temp) - Len(joinString))
End Function
answered Feb 11 at 20:58
Christofer WeberChristofer Weber
774413
774413
Thank you Christofer I appreciate the code. this is very helpful. I don't have enough reputation to upvote, I have also been working on some code for this I wrote above. if you have the time i would love if you could review it and give some constructive feedback/ Suggestions
– Mark
Feb 19 at 19:59
add a comment |
Thank you Christofer I appreciate the code. this is very helpful. I don't have enough reputation to upvote, I have also been working on some code for this I wrote above. if you have the time i would love if you could review it and give some constructive feedback/ Suggestions
– Mark
Feb 19 at 19:59
Thank you Christofer I appreciate the code. this is very helpful. I don't have enough reputation to upvote, I have also been working on some code for this I wrote above. if you have the time i would love if you could review it and give some constructive feedback/ Suggestions
– Mark
Feb 19 at 19:59
Thank you Christofer I appreciate the code. this is very helpful. I don't have enough reputation to upvote, I have also been working on some code for this I wrote above. if you have the time i would love if you could review it and give some constructive feedback/ Suggestions
– Mark
Feb 19 at 19:59
add a comment |
I appreciate the help from everyone, I have been working tirelessly on this and I learned a lot, so I wanted to share the code I wrote for this. I have included a few references commented in the code I used. also if you have any further suggestions I would love to hear them.
This Code will:
Create a dictionary of user identified cause Values to look out for, and create a dictionary of cause Values with a matching CE-Name.
It will concatenate the Symp that have a matching CE name and identify the concatenated cell by highlighting it as long as the "user identified cause Values" are not present in the Matching CE Cause Dictionary
It will identify the extra (unnecessary Rows) Rows as N/A
It will remove any row with N/A
It will then sort the data by Identified (Colored) Rows
Private Sub Auto_Combine() 'Step 5 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'WIP Auto Combine cells based on Symp value
'******************************************************************************
'Variables
Dim PrevRefCell As String 'Refers to the Complaint Number Column A
Dim CurrRefCell As String 'Refers to the Complaint Number Column A
Dim PrevCombCell As Range
Dim CurrCombCell As Range
Dim PrevSympCell As String
Dim CurrSympCell As String
Dim PrevCausCell As Range
Dim CurrCausCell As Range
Dim FirstFour As String
Dim PrevFirstFour As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Dim i As Long
Dim Flag As Boolean
Dim CauseDict As Object
Set CauseDict = CreateObject("Scripting.Dictionary")
CauseDict.Add "L101", "L101"
CauseDict.Add "X101", "X101"
CauseDict.Add "L304", "L304"
Dim CauseDictItem As Variant
Dim CurCauseDict As Object
Set CurCauseDict = CreateObject("Scripting.Dictionary")
Dim j As Variant
Dim l As Variant
Dim RefDict As Object
Set RefDict = CreateObject("Scripting.Dictionary")
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
'Assign increment cell locations to variables
CurrRefCell = ActiveSheet.Range("A" & CurRRow).Value
CurrSympCell = ActiveSheet.Range("P" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("A" & PrevRow).Value
PrevSympCell = ActiveSheet.Range("P" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, PrevRefCell) > 0 Then ' If A.1
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
' combine Symptom code combos to combo cell in column "O"
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
Set PrevCombCell = ActiveSheet.Range("O" & PrevRow)
CurrCombCell.Value = CurrSympCell & "," & PrevCombCell.Value
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
Set PrevCausCell = ActiveSheet.Range("R" & PrevRow)
' After Combo is made N/A previous combo cell
PrevCombCell.Value = "N/A"
FirstFour = Left(CurrCausCell, 4)
PrevFirstFour = Left(PrevCausCell, 4)
If Not CurCauseDict.Exists(PrevFirstFour) Then
CurCauseDict.Add PrevFirstFour, PrevFirstFour
End If
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
End If
' Look for non "L101" cause codes can highlight CurrCombCell Yellow based on values
i = i - 1
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.1 If Begin
For Each l In CurCauseDict.Keys
If CauseDict.Exists(l) Then
Flag = True
End If
Next
If Flag = True Then
'__________________
Else
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
End If
ColorSKIP: '-----------------------------------------------------------------------------
'Nested Loop A.1.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Else Begin
' if only single line item assign current symp to current comb location
Else 'A.1 Else Begin
CurCauseDict.RemoveAll
i = 0
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
CurrCombCell.Value = CurrSympCell
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
FirstFour = Left(CurrCausCell, 4)
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
On Error Resume Next
End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.2 If Begin
For Each j In CurCauseDict.Keys
If Not CauseDict.Exists(j) Then ' if current "beginning" dict key is in "ending" dict
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
CurCauseDict.RemoveAll
Flag = False
End If
Next
'Nested Loop A.1.2 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End If 'A.1 Else End
'Nested Loop A.1 Else End
'Nested Loop A.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
'For Loop A End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Sub AA2_NA_Data_Sort() 'Step 6 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Variables
Dim PrevRefCell As String
Dim CurrRefCell As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Range("A1").Select
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
CurrRefCell = ActiveSheet.Range("O" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("O" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, "N/A") > 0 Then
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
ActiveSheet.Range("A" & CurRRow).Activate
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
End If
' Else
'Nested Loop A.1 Else End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
End Sub
Sub AA3_Color_Sort() 'Step 7 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Sort by CE Name
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'******************************************************************************
'Sort By Color no fill on top
' Range("A1:U120").Select
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("O:O"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
add a comment |
I appreciate the help from everyone, I have been working tirelessly on this and I learned a lot, so I wanted to share the code I wrote for this. I have included a few references commented in the code I used. also if you have any further suggestions I would love to hear them.
This Code will:
Create a dictionary of user identified cause Values to look out for, and create a dictionary of cause Values with a matching CE-Name.
It will concatenate the Symp that have a matching CE name and identify the concatenated cell by highlighting it as long as the "user identified cause Values" are not present in the Matching CE Cause Dictionary
It will identify the extra (unnecessary Rows) Rows as N/A
It will remove any row with N/A
It will then sort the data by Identified (Colored) Rows
Private Sub Auto_Combine() 'Step 5 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'WIP Auto Combine cells based on Symp value
'******************************************************************************
'Variables
Dim PrevRefCell As String 'Refers to the Complaint Number Column A
Dim CurrRefCell As String 'Refers to the Complaint Number Column A
Dim PrevCombCell As Range
Dim CurrCombCell As Range
Dim PrevSympCell As String
Dim CurrSympCell As String
Dim PrevCausCell As Range
Dim CurrCausCell As Range
Dim FirstFour As String
Dim PrevFirstFour As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Dim i As Long
Dim Flag As Boolean
Dim CauseDict As Object
Set CauseDict = CreateObject("Scripting.Dictionary")
CauseDict.Add "L101", "L101"
CauseDict.Add "X101", "X101"
CauseDict.Add "L304", "L304"
Dim CauseDictItem As Variant
Dim CurCauseDict As Object
Set CurCauseDict = CreateObject("Scripting.Dictionary")
Dim j As Variant
Dim l As Variant
Dim RefDict As Object
Set RefDict = CreateObject("Scripting.Dictionary")
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
'Assign increment cell locations to variables
CurrRefCell = ActiveSheet.Range("A" & CurRRow).Value
CurrSympCell = ActiveSheet.Range("P" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("A" & PrevRow).Value
PrevSympCell = ActiveSheet.Range("P" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, PrevRefCell) > 0 Then ' If A.1
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
' combine Symptom code combos to combo cell in column "O"
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
Set PrevCombCell = ActiveSheet.Range("O" & PrevRow)
CurrCombCell.Value = CurrSympCell & "," & PrevCombCell.Value
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
Set PrevCausCell = ActiveSheet.Range("R" & PrevRow)
' After Combo is made N/A previous combo cell
PrevCombCell.Value = "N/A"
FirstFour = Left(CurrCausCell, 4)
PrevFirstFour = Left(PrevCausCell, 4)
If Not CurCauseDict.Exists(PrevFirstFour) Then
CurCauseDict.Add PrevFirstFour, PrevFirstFour
End If
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
End If
' Look for non "L101" cause codes can highlight CurrCombCell Yellow based on values
i = i - 1
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.1 If Begin
For Each l In CurCauseDict.Keys
If CauseDict.Exists(l) Then
Flag = True
End If
Next
If Flag = True Then
'__________________
Else
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
End If
ColorSKIP: '-----------------------------------------------------------------------------
'Nested Loop A.1.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Else Begin
' if only single line item assign current symp to current comb location
Else 'A.1 Else Begin
CurCauseDict.RemoveAll
i = 0
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
CurrCombCell.Value = CurrSympCell
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
FirstFour = Left(CurrCausCell, 4)
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
On Error Resume Next
End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.2 If Begin
For Each j In CurCauseDict.Keys
If Not CauseDict.Exists(j) Then ' if current "beginning" dict key is in "ending" dict
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
CurCauseDict.RemoveAll
Flag = False
End If
Next
'Nested Loop A.1.2 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End If 'A.1 Else End
'Nested Loop A.1 Else End
'Nested Loop A.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
'For Loop A End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Sub AA2_NA_Data_Sort() 'Step 6 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Variables
Dim PrevRefCell As String
Dim CurrRefCell As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Range("A1").Select
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
CurrRefCell = ActiveSheet.Range("O" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("O" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, "N/A") > 0 Then
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
ActiveSheet.Range("A" & CurRRow).Activate
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
End If
' Else
'Nested Loop A.1 Else End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
End Sub
Sub AA3_Color_Sort() 'Step 7 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Sort by CE Name
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'******************************************************************************
'Sort By Color no fill on top
' Range("A1:U120").Select
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("O:O"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
add a comment |
I appreciate the help from everyone, I have been working tirelessly on this and I learned a lot, so I wanted to share the code I wrote for this. I have included a few references commented in the code I used. also if you have any further suggestions I would love to hear them.
This Code will:
Create a dictionary of user identified cause Values to look out for, and create a dictionary of cause Values with a matching CE-Name.
It will concatenate the Symp that have a matching CE name and identify the concatenated cell by highlighting it as long as the "user identified cause Values" are not present in the Matching CE Cause Dictionary
It will identify the extra (unnecessary Rows) Rows as N/A
It will remove any row with N/A
It will then sort the data by Identified (Colored) Rows
Private Sub Auto_Combine() 'Step 5 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'WIP Auto Combine cells based on Symp value
'******************************************************************************
'Variables
Dim PrevRefCell As String 'Refers to the Complaint Number Column A
Dim CurrRefCell As String 'Refers to the Complaint Number Column A
Dim PrevCombCell As Range
Dim CurrCombCell As Range
Dim PrevSympCell As String
Dim CurrSympCell As String
Dim PrevCausCell As Range
Dim CurrCausCell As Range
Dim FirstFour As String
Dim PrevFirstFour As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Dim i As Long
Dim Flag As Boolean
Dim CauseDict As Object
Set CauseDict = CreateObject("Scripting.Dictionary")
CauseDict.Add "L101", "L101"
CauseDict.Add "X101", "X101"
CauseDict.Add "L304", "L304"
Dim CauseDictItem As Variant
Dim CurCauseDict As Object
Set CurCauseDict = CreateObject("Scripting.Dictionary")
Dim j As Variant
Dim l As Variant
Dim RefDict As Object
Set RefDict = CreateObject("Scripting.Dictionary")
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
'Assign increment cell locations to variables
CurrRefCell = ActiveSheet.Range("A" & CurRRow).Value
CurrSympCell = ActiveSheet.Range("P" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("A" & PrevRow).Value
PrevSympCell = ActiveSheet.Range("P" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, PrevRefCell) > 0 Then ' If A.1
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
' combine Symptom code combos to combo cell in column "O"
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
Set PrevCombCell = ActiveSheet.Range("O" & PrevRow)
CurrCombCell.Value = CurrSympCell & "," & PrevCombCell.Value
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
Set PrevCausCell = ActiveSheet.Range("R" & PrevRow)
' After Combo is made N/A previous combo cell
PrevCombCell.Value = "N/A"
FirstFour = Left(CurrCausCell, 4)
PrevFirstFour = Left(PrevCausCell, 4)
If Not CurCauseDict.Exists(PrevFirstFour) Then
CurCauseDict.Add PrevFirstFour, PrevFirstFour
End If
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
End If
' Look for non "L101" cause codes can highlight CurrCombCell Yellow based on values
i = i - 1
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.1 If Begin
For Each l In CurCauseDict.Keys
If CauseDict.Exists(l) Then
Flag = True
End If
Next
If Flag = True Then
'__________________
Else
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
End If
ColorSKIP: '-----------------------------------------------------------------------------
'Nested Loop A.1.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Else Begin
' if only single line item assign current symp to current comb location
Else 'A.1 Else Begin
CurCauseDict.RemoveAll
i = 0
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
CurrCombCell.Value = CurrSympCell
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
FirstFour = Left(CurrCausCell, 4)
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
On Error Resume Next
End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.2 If Begin
For Each j In CurCauseDict.Keys
If Not CauseDict.Exists(j) Then ' if current "beginning" dict key is in "ending" dict
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
CurCauseDict.RemoveAll
Flag = False
End If
Next
'Nested Loop A.1.2 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End If 'A.1 Else End
'Nested Loop A.1 Else End
'Nested Loop A.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
'For Loop A End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Sub AA2_NA_Data_Sort() 'Step 6 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Variables
Dim PrevRefCell As String
Dim CurrRefCell As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Range("A1").Select
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
CurrRefCell = ActiveSheet.Range("O" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("O" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, "N/A") > 0 Then
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
ActiveSheet.Range("A" & CurRRow).Activate
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
End If
' Else
'Nested Loop A.1 Else End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
End Sub
Sub AA3_Color_Sort() 'Step 7 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Sort by CE Name
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'******************************************************************************
'Sort By Color no fill on top
' Range("A1:U120").Select
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("O:O"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
I appreciate the help from everyone, I have been working tirelessly on this and I learned a lot, so I wanted to share the code I wrote for this. I have included a few references commented in the code I used. also if you have any further suggestions I would love to hear them.
This Code will:
Create a dictionary of user identified cause Values to look out for, and create a dictionary of cause Values with a matching CE-Name.
It will concatenate the Symp that have a matching CE name and identify the concatenated cell by highlighting it as long as the "user identified cause Values" are not present in the Matching CE Cause Dictionary
It will identify the extra (unnecessary Rows) Rows as N/A
It will remove any row with N/A
It will then sort the data by Identified (Colored) Rows
Private Sub Auto_Combine() 'Step 5 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'WIP Auto Combine cells based on Symp value
'******************************************************************************
'Variables
Dim PrevRefCell As String 'Refers to the Complaint Number Column A
Dim CurrRefCell As String 'Refers to the Complaint Number Column A
Dim PrevCombCell As Range
Dim CurrCombCell As Range
Dim PrevSympCell As String
Dim CurrSympCell As String
Dim PrevCausCell As Range
Dim CurrCausCell As Range
Dim FirstFour As String
Dim PrevFirstFour As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Dim i As Long
Dim Flag As Boolean
Dim CauseDict As Object
Set CauseDict = CreateObject("Scripting.Dictionary")
CauseDict.Add "L101", "L101"
CauseDict.Add "X101", "X101"
CauseDict.Add "L304", "L304"
Dim CauseDictItem As Variant
Dim CurCauseDict As Object
Set CurCauseDict = CreateObject("Scripting.Dictionary")
Dim j As Variant
Dim l As Variant
Dim RefDict As Object
Set RefDict = CreateObject("Scripting.Dictionary")
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
'Assign increment cell locations to variables
CurrRefCell = ActiveSheet.Range("A" & CurRRow).Value
CurrSympCell = ActiveSheet.Range("P" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("A" & PrevRow).Value
PrevSympCell = ActiveSheet.Range("P" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, PrevRefCell) > 0 Then ' If A.1
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
' combine Symptom code combos to combo cell in column "O"
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
Set PrevCombCell = ActiveSheet.Range("O" & PrevRow)
CurrCombCell.Value = CurrSympCell & "," & PrevCombCell.Value
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
Set PrevCausCell = ActiveSheet.Range("R" & PrevRow)
' After Combo is made N/A previous combo cell
PrevCombCell.Value = "N/A"
FirstFour = Left(CurrCausCell, 4)
PrevFirstFour = Left(PrevCausCell, 4)
If Not CurCauseDict.Exists(PrevFirstFour) Then
CurCauseDict.Add PrevFirstFour, PrevFirstFour
End If
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
End If
' Look for non "L101" cause codes can highlight CurrCombCell Yellow based on values
i = i - 1
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.1 If Begin
For Each l In CurCauseDict.Keys
If CauseDict.Exists(l) Then
Flag = True
End If
Next
If Flag = True Then
'__________________
Else
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
End If
ColorSKIP: '-----------------------------------------------------------------------------
'Nested Loop A.1.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Else Begin
' if only single line item assign current symp to current comb location
Else 'A.1 Else Begin
CurCauseDict.RemoveAll
i = 0
Set CurrCombCell = ActiveSheet.Range("O" & CurRRow)
CurrCombCell.Value = CurrSympCell
Set CurrCausCell = ActiveSheet.Range("R" & CurRRow)
FirstFour = Left(CurrCausCell, 4)
If Not CurCauseDict.Exists(FirstFour) Then
CurCauseDict.Add FirstFour, FirstFour
On Error Resume Next
End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1.2 If Begin
For Each j In CurCauseDict.Keys
If Not CauseDict.Exists(j) Then ' if current "beginning" dict key is in "ending" dict
CurrCombCell.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
End With
CurCauseDict.RemoveAll
Flag = False
End If
Next
'Nested Loop A.1.2 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End If 'A.1 Else End
'Nested Loop A.1 Else End
'Nested Loop A.1 If End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
'For Loop A End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
Sub AA2_NA_Data_Sort() 'Step 6 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Variables
Dim PrevRefCell As String
Dim CurrRefCell As String
Dim sh As Worksheet
Dim rn As Range
Dim k As Long
Dim CurRRow As Long
Dim PrevRow As Long
Range("A1").Select
'******************************************************************************
'Counts Number Of active rows in ActiveSheet and set to variable "k"
'https://stackoverflow.com/questions/25056372/vba-range-row-count
Set sh = ThisWorkbook.ActiveSheet
'Set rn = sh.UsedRange
Set rn = Range("A1", sh.Range("A1").End(xlDown).End(xlDown).End(xlUp))
k = rn.Rows.Count + rn.Row - 1
'******************************************************************************
'Use this to incrememnt actual address
'Sets Values of ref cells to cell contents
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop A Begin
For CurRRow = 1 To k ' set row value currently at max row "k"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Insert Instructions Set below
PrevRow = CurRRow - 1
CurrRefCell = ActiveSheet.Range("O" & CurRRow).Value
On Error GoTo ErrHandler:
PrevRefCell = ActiveSheet.Range("O" & PrevRow).Value
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'Nested Loop A.1 Begin
'Compare Values and does set of instruction based on those values. in this case
'"PrevRefCell" and "CurrRefCell"
If InStr(CurrRefCell, "N/A") > 0 Then
'https://www.techonthenet.com/excel/formulas/instr.php
'https://www.techonthenet.com/excel/formulas/if_then.php
ActiveSheet.Range("A" & CurRRow).Activate
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
End If
' Else
'Nested Loop A.1 Else End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'For Loop End
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ErrHandler:
Next CurRRow
End Sub
Sub AA3_Color_Sort() 'Step 7 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'******************************************************************************
'Sort by CE Name
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'******************************************************************************
'Sort By Color no fill on top
' Range("A1:U120").Select
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add key:=Range _
("O:O"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
answered Feb 19 at 19:56
MarkMark
134
134
add a comment |
add a comment |
Thanks for contributing an answer to Super User!
- Please be sure to answer the question. Provide details and share your research!
But avoid …
- Asking for help, clarification, or responding to other answers.
- Making statements based on opinion; back them up with references or personal experience.
To learn more, see our tips on writing great answers.
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fsuperuser.com%2fquestions%2f1400713%2fvba-code-to-concatenate-cells-based-on-values-in-other-columns%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Interesting, Yes you could record a macro do give you the framework, then generalize it. However, if I understand your needs maybe a pivot table could solve your problem. It won't do the concatenate, but will create the groups I think you are looking for. Maybe that will be sufficient...
– gns100
Jan 31 at 19:30
Unfortunately the concatenated data is the most relevant to the final data presented. i've been sorting the data the "Manual" way for a long time. i've started learning some VBA but this is way out of my current ability.
– Mark
Feb 1 at 1:22
How do you separate the data samples? In the same table separated by an empty line like in image 3? Wouldn't that break if you sort something? Why does LC106855 and LC109164 end up in different samples?
– Christofer Weber
Feb 2 at 18:26
The data samples are separated here by a blank row but its not required. It can be a different sheet I just separate it here by a blank row since its a manual process and I only had the top data set autofiltered when I made this so it would'nt mess up the sorting. you are also correct I made a mistake when I quickly put this data set together. LC109164 should be part of "Data Sample 1" not 2
– Mark
Feb 4 at 19:48