I have the following data set, which contains duplicates.
values:
2880CR-20.36KX53305DECOAK2015
F05572-CN48517OCTOAK2016
F05572-CN48517DECOAK2016
F05572-CN48517NOVOAK2015
F05572-CN48517NOVOAK2015(duplicate)
F05572-CN48517DECOAK2015
F05573-CN48517JANOAK2016
F05573-CN48517FEBOAK2016
F05573-CN48517JANOAK2015
F05573-CN48517FEBOAK2015
F05573-CN48517MAROAK2015
F05573-CN48517APROAK2015
F05573-CN48517APROAK2015(duplicate)
I am trying to create a macro that will look at the values in column A, from A2:A (count of rows in column), and return a list of the duplicate values contained in the string declared "strMyDupList". Basically, if there is atleast 1 duplicate, the msgbox will pop up and the new sheet created with the columns address and values and I am trying to list out all the values seperated my a comma VERTICALLY, instead of horizontally across the sheet. so like:
Address value
$A$5 F05572-CN48517NOVOAK2015
$A$13 F05573-CN48517APROAK2015
my code is :
If strMyDupList <> "" Then
MsgBox "The following entries have been used more than once:" & vbNewLine & strMyDupList
Worksheets.Add.name = name
Worksheets(name).Range("A1").Value = "Location"
Worksheets(name).Range("B1").Value = "Value"
' Worksheets(name).Range("A2:C2").Value = Split(strMyDupList, ",")
Worksheets(name).Range("B4:B6") = Split(Application.WorksheetFunction.Transpose(strMyDupList), ",")
The results are that I am able to get the values tranposed from horizontal to vertical, however, with this code, it is only returning the FIRST VALUE in the list of values in the string, so it's returning:
Address value
$A$5 F05572-CN48517NOVOAK2015
$A$5 F05572-CN48517NOVOAK2015 (should be F05573-CN48517APROAK2015)
I've seen the UBound with Resize could work but I have no idea how the syntax works or is used. Can someone assist?
Thank you
Here is a complete example of how to leave duplicates out of your information.
Essentially, it sorts all of your information. Therefore, when you sort you'll get the consecutive value which would be itself if it was a dupe.
It uses a .NET feature, System.Collections.ArrayList, that was in 2.0 & 3.5 so that has to be installed on your machine. Usually it already is but it may not be. You can turn it on through Programs & Features.
Sub StringArrayDupeChecker()
Dim var As Variant
Dim holder As String
Dim strMyList() As String
Dim myDupeData As Variant
Dim str As String
str = "one,two,three,three,three,four,five,five"
strMyList = Split(str, ",")
holder = ""
Set var = CreateObject("System.Collections.ArrayList")
Set myDupeData = CreateObject("System.Collections.ArrayList")
For Each i In strMyList
var.Add (i)
Next i
var.Sort
For Each j In var
If Not j = holder Then
'do your stuff
str = "notDupe"
Else
myDupeData.Add(j)
End If
holder = j
Next j
End Sub
Related
I'm currently busy with Excel tooling and learning a lot but i got a question. Currently i have a couple rows with data in the rows. In the rows there is a lot of data but i need a specific part of the row. Of course i can delete it all manually but to do that for 3000 rows i will be wasting a lot of time.
Can any one help me with a macro that filters data. The data i need is between [ and ] so for example [data]
I hope you guys can help me out and if you need more information just ask me! I hope you guys can help me!
Example String ROW:
[Sandwitch]><xsd:element name="T8436283"
So what do i need?
So i need a macro that only gets the Sandwitch out of it and paste it in the B column. The string with all the information stays at column A and the Sandwitch goes to Column B and that for all rows.
Option 1: Find/Replace
1) Copy data in another column (just saving original copy)
2) Perform Find/Replace "*["
3) Perform Find/Replace "]"
Now you have data which was between [].
Option 2: Use formulas
1) Lets assume that original data in Column "A"
2) Apply this formula in column "B" which will extract data between []
=MID(A1,FIND("[",A1)+1,FIND("]",A1)-FIND("[",A1)-1)
Option 3: Macro
If it is absolutely needed, I can help create a macro, otherwise try first two easier options.
A general purpose "find element in s starting x up to next y":
Function GenExtract(FromStr As String, _
StartSep As String, EndSep As String) _
As Variant
Dim StPos As Long
Dim EnPos As Long
GenExtract = CVErr(xlErrNA)
If StartSep = "" Or EndSep = "" Then Exit Function 'fail
StPos = InStr(1, FromStr, Left(StartSep, 1))
If StPos = 0 Or StPos = Len(FromStr) Then Exit Function 'fail
EnPos = InStr(StPos + 1, FromStr, Left(EndSep, 1))
If EnPos = 0 Then Exit Function 'fail
GenExtract = Mid(FromStr, StPos + 1, EnPos - StPos - 1)
End Function
If the two separators are the same, as per quotes, it gives the first string enclosed by those.
If you want to get your feet wet in Regular Expressions, the following code will take you there. You have to add a reference to the VB Scripting Library
Tools > References > Microsoft VBScript Regular Expressions 5.5
Then the code is as follows:
Sub textBetweenStuffs()
Dim str As String
Dim regEx As RegExp
Dim m As Match
Dim sHolder As MatchCollection
Dim bracketCollection As Collection
Dim quoteCollection As Collection
Set regEx = New RegExp
'Matches anything in between an opening bracket and first closing bracket
regEx.Pattern = "\[(.*?\])"
str = "[Sandwitch]><xsd:element name=""T8436283"""
'populates matches into match collection
Set sHolder = regEx.Execute(str)
Set bracketCollection = New Collection
'loop through values in match collection to do with as you wish
For Each m In sHolder
bracketCollection.Add m.Value
Next i
Set sHolder = Nothing
'get values between Quotations
regEx.Pattern = "\"(.*?\")"
'populates matches into match collection
Set sHolder = regEx.Execute(str)
Set quoteCollection = New Collection
'loop through values in match collection to do with as you wish
For Each m In sHolder
quoteCollection.Add m.Value
Next i
End Sub
I have data that it's not in a consistent position in the cell, sometimes it has a semicolon, sometimes it is to the right or the left of the semicolon. The end result I'm looking is to have in column B all "students" (defined by not being teacher) and in Column C, all Teachers. If no student or teacher is found, then the corresponding cell should be blank.
Currently I'm doing a text to columns to separate both columns then using the following formulas to have the student and teacher separate:
=IF(SUMPRODUCT(--ISNUMBER(SEARCH({"Arts and Music","Math and Science"},A2)))>0,B2,C2)
=IF(SUMPRODUCT(--ISNUMBER(SEARCH("Teacher",A2)))>0,B2,C2)
I still have to do a manual Find and replace to remove the parenthesis and text and leave only the student/teacher name.
IS there any VBA macro that can help me to get from Column A to my expected result in columns B and C? Thank you.
You can use regular expressions to do this. See this post on how to enable them in excel.
Sub FindStrAndCopy()
Dim regEx As New RegExp
regEx.Pattern = "\s*(\w+)\s*\((.+)\)"
With Sheets(1):
Dim arr() As String
Dim val As String
Dim i As Integer, j As Integer
Dim person As String, teachOrSubject As String
Dim mat As Object
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row:
val = Cells(i, "A").Value
arr = Split(val, ";")
For j = 0 To UBound(arr):
Set mat = regEx.Execute(arr(j))
If mat.Count = 1 Then
person = mat(0).SubMatches(0)
teachOrSubject = mat(0).SubMatches(1)
If teachOrSubject = "Teacher" Then
Cells(i, "C").Value = person
Else
Cells(i, "B").Value = person
End If
End If
Next
Next
End With
End Sub
The macro splits the string on a semicolon and stores either 1 or 2 substrings in the 'arr' array. It then does a regular expression on each one. If the string inside the parenthesis is "Teacher" then the preceding person's name is stored in column "C" otherwise it's a student and the name is stored in column "B".
I create a button that read all the registers you have on column A
then put the students on column B
then put the Teacher on column C
Check that I used "(Teacher)" to know when a teacher is in the String
I used the sheet Called "Sheet1"
And I don't use the first row because is the header row.
If you have any question please contact me.
Private Sub CommandButton1_Click()
'---------------------------------Variables-----------------------------
Dim total, i, j As Integer
'--------------Counting the number of the register in column A----------
ThisWorkbook.Sheets("Sheet1").Range("XDM1").Formula = "=COUNTA(A:A)"
total = CInt(ThisWorkbook.Sheets("Sheet1").Range("XDM1").Value)
'---------------------Creating arrays to read the rows------------------
Dim rows(0 To 1000) As String
Dim columnsA() As String
'------------Searching into the rows to find teacher or student---------
For i = 2 To total
columnsA = Split(ThisWorkbook.Sheets("Sheet1").Range("A" & i).Value, ";")
first = LBound(columnsA)
last = UBound(columnsA)
lenghtOfArray = last - first
MsgBox lenghOfArray
For j = 0 To lenghtOfArray
If InStr(columnsA(j), "(Teacher)") > 0 Then
MsgBox columnsA(j)
ThisWorkbook.Sheets("Sheet1").Range("C" & i).Value = columnsA(j)
Else
ThisWorkbook.Sheets("Sheet1").Range("B" & i).Value = columnsA(j)
End If
Next j
Next i
'--------------------------------Finishing------------------------------
End Sub
This is what my cells look like:
This is my code, I'll explain it below.
Sub Macro1()
Dim product as String
Dim group as Long
Dim recordno as Long
dim pol_number as Long
dim plan_name as Long
product = "corp"
group = 1
recordno = 1
pol_number = 1
plan_name = "TTT"
Range("A2").Select
For i = 1 to 5
ActiveCell.Value = Selection.End(xlUp).Value
ActiveCell.Offset(0,1).Select
Next i
End Sub
I want to fill in all of the cells with the variable values. I understand that variables are not case sensitive, and I understand that the code I have will just fill the cell with the text in the upmost cell of the column, but I don't know if there is a function that would take the text of the top cell and convert it to a variable. Is that possible?
Try this to go from variables to cells
Dim values as Variant
'Array 0 to 4
values = Array(product,group,recordno,pol_number,plan_name)
Range("A2").Resize(1,5).Value2 = values
The reverse is
Dim values as Variant
'Array 1 to 5
values = Range("A2").Resize(1,5).Value2
product = values(1,1)
group = values(1,2)
recordno = values(1,3)
pol_number = values(1,4)
plan_name = values(1,5)
If you do something like
someCell.Value = someOtherCell.Value
and someOtherCell.Value is "product" then someCell won't be filled with what you have saved in the variable product but with "product" (I included the quotation marks to emphasize that's it's a string). That's a good thing because otherwise it would mess your code up if you accidentally put in the name of some random variable in your code.
If your requirements are like this:
You have values for PRODUCT etc that you write to write in the row below PRODUCT etc.
The headers are not always in the same order.
You might want to add new variables later on without too much fuss.
Them some kind of keyed list might be what your looking for. That means that rather than referencing the variable by a numerical index, you can reference them using names.
If the order is fixed, you might be better of just using an array where item 1 is the product name, item 2 is the group number etc, like ja72 and Sgdva suggested.
However, if you still want to reference the variables by name, you could use a collection:
Dim coll As New Collection
With coll
.Add "corp", "product"
.Add 1, "group"
.Add 1, "recordno"
'...
End With
Then instead of selecting cells and referencing ActiveCell you should reference the cells directly (using selections and ActiveCell can be avoided most of the times and slows down the macro and can even cause unnecessary errors)
For i = 1 To 5
Cells(2, i).value = coll(Cells(1, i).value)
Next i
An alternative to a collection is a dictionary which offers an easy way to check if a key exists (with a collection you have to catch the error)
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With dict
.Add "product", "corp"
.Add "group", 1
.Add "recordno", 1
'...
End With
Now you can check if the entry exists first so it won't throw an error:
For i = 1 To 5
If dict.Exists(LCase(Cells(1, i).value)) Then 'note that the dictionary keys are case sensitive
Cells(2, i).value = dict(LCase(Cells(1, i).value))
Else
MsgBox "Entry for " & LCase(Cells(1, i).value) & " not found!"
End If
Next i
Note that when you use dict("somekey") and the entry "somekey" doesn't exist, it won't throw an error but add an empty entry.
Why not an array and then loop through the elements as needed?
Dim ArrayTitles() As Variant 'since strings and numbers are mixed
ReDim Preserve ArrayTitles(5)
ArrayTitles(1) = "corp"
ArrayTitles(2) = 1
ArrayTitles(3) = 1
ArrayTitles(4) = 1
ArrayTitles(5) = "TTT"
Range("A2").Select
For i = 1 To 5
MsgBox (ArrayTitles(i))
I'm thinking what you are trying to accomplish can be solved in this way
for j = 1 to 6 'Or whatever your last column happens to be
if UCase(cells(1, j)) = "PRODUCT" then
if ActiveCell.Column = j then
ActiveCell.Value = "corp"
end if
end if
next j
Something like that?
I am looking for some code that can search cell by cell in the 2nd column of a table for numbers and decimal points, cut them and paste them in the cell to the left whilst leaving the text behind.
For example:
1(tab space)Test
1.1(tab space)Test
1.1.1(tab space)Test
1.1.1.1(tab space)Test
Where the bullet points represent separate cells in different columns.
In all instances the numbers are separated from the text by a tab space "Chr9" (as indicated in the example)
Any help or useful snippets of code would much appreciated!
EDIT: I have some code that scans each cell in a column but I dont know the code to tell it to only cut numbers and decimal points up to the first tab space.
The Split function delivers what you are after. Sample code:
Dim inputString As String
Dim splitArray() As String
Dim result As String
inputString = "1 Test"
splitArray = Split(inputString, " ")
If(UBound(splitArray) >= 1) Then 'Making sure that it found something before using it
result = splitArray(1) 'Text
End If
inputString = "1.1 Test"
splitArray = Split(inputString, " ")
If(UBound(splitArray) >= 1) Then
result = splitArray(1) 'Text
End If
'etc.
UPDATE
Code delivering the functionality you want:
Dim splitArray() As String
Dim curTable As Table
Set curTable = ActiveDocument.Tables(1)
For Row = 1 To curTable.Rows.Count
With curTable
splitArray = Split(.Cell(Row, 2).Range.Text, " ")
If (UBound(splitArray) >= 1) Then
.Cell(Row, 2).Range.Text = splitArray(1)
.Cell(Row, 1).Range.Text = splitArray(0)
End If
End With
Next Row
I have a dated CS degree so I understand the basics of VB but I don't write macros very often and need help solving a particular condition. (...but I understand functions and object oriented programming)
Assume the following:
- Column A contains reference ID's in alphanumeric form, sorted alphabetically.
- Column B contains strings of text, or blanks.
I'm trying to write a macro that automatically removes any extra rows for each unique reference number based on the contents of the "Notes" in column B. The problem is that if column A has multiple instances of a unique ref number, I need to identify which row contains something in column B. There is one catch: it is possible that the reference number has nothing in column B and should be retained.
To explain further, in the following screenshot I would need to:
Keep the yellow highlighted rows
Delete the remaining rows
I tried to show various configurations of how the report might show the data using the brackets on the right and marked in red. Its difficult to explain what I'm trying to do so I figured a picture would show what I need more clearly.
This task is making the report very manual and time consuming.
it's pretty simple
you just go throug the rows and check whether this row needs to be deleted, an earlier row with this id needs to be deleted or nothing should happen.
in my example i mark these rows and delete them in the end.
Sub foo()
Dim rngSelection As Range
Dim startingRow As Integer
Dim endRow As Integer
Dim idColumn As Integer
Dim noteColumn As Integer
Dim idValuableRow As New Dictionary
Dim deleteRows As New Collection
Set rngSelection = Selection
startingRow = rngSelection.Row
endRow = rngSelection.Rows.Count + startingRow - 1
idColumn = rngSelection.Column
noteColumn = idColumn + 1
For i = startingRow To endRow
currentID = Cells(i, idColumn)
If idValuableRow.Exists(currentID) Then
If Trim(idValuableRow(currentID)("note")) <> "" And Trim(Cells(i, noteColumn)) = "" Then
deleteRows.Add i
ElseIf idValuableRow(currentID)("note") = "" And Trim(Cells(i, noteColumn)) <> "" Then
deleteRows.Add idValuableRow(currentID)("row")
idValuableRow(currentID)("row") = i
idValuableRow(currentID)("note") = Cells(i, noteColumn)
End If
Else
Dim arr(2) As Variant
idValuableRow.Add currentID, New Dictionary
idValuableRow(currentID).Add "row", i
idValuableRow(currentID).Add "note", Cells(i, noteColumn)
End If
Next i
deletedRows = 0
For Each element In deleteRows
If element <> "" Then
Rows(element - deletedRows & ":" & element - deletedRows).Select
Selection.Delete Shift:=xlUp
deletedRows = deletedRows + 1
End If
Next element
End Sub
it could look something like this. the only thing you need is to add Microsoft Scripting Runtime in Tools/References