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
Related
I'm trying to use the MATCH function to determine a row. I have several holes and some of the holes go through numerous parts (ex: hole 1 could go through two parts, but Hole 2, next to it, could go through four parts). The diameters could be different in each layer, and can vary by quite a bit. I need to pull the correct diameter for the layer. My code works up to the line where I try to get j equal to the row number that the next hole is on. I think my problem is with the range. I'd like to use the table header, since the input table size can vary from project to project.
I updated the code to reflect the suggestions in the comment and the research I was able to do to use the table header in the MATCH function. The issue now is that it pulls the row below what I would have anticipated. Using the code on the example table, j , the row that MATCH returns, is 5, which is a row for Hole 3, unless it counts the header row, but I thought that using dataBodyRange would exclude that row. Note that my table begins at cell A5. I think I still have a reference issue.
Private Sub UpdatePitchDia_Click()
'Want to use diameters from the same part
Dim i
Dim j
Dim LastRowIn
Dim Hole_Num
Dim Incoming_Dia
Dim Hole_L
Dim Hole_R
Dim Hole_U
Dim Hole_D
Dim Stack_Up
Dim Stack_Up_L
Dim L_Dia
Dim tbl_In As ListObject
Dim Hole As Range
Set tbl_In = ThisWorkbook.Sheets("Input").ListObjects("tbl_Input")
Set Hole = tbl_In.ListColumns(1).Range
LastRowIn = tbl_In.DataBodyRange.Rows.Count
i = 1
j = 0
For i = 1 To LastRowIn Step 1
Hole_L = [tbl_Input].Cells(i, 4)
If Not IsEmpty(Hole_L) Then 'Not all holes have adjacent holes
'Need to make sure that the part layers are the same
j = WorksheetFunction.Match(Hole_L, Hole, 0)
'MsgBox "Row of Hole Left (" & Hole_L & ") is " & j
Stack_Up = [tbl_Input].Cells(i, 2)
Stack_Up_L = [tbl_Input].Cells(j, 2)
If Stack_Up <> Stack_Up_L Then
j = j + 1
Stack_Up_L = [tbl_Input].Cells(j, 2)
Else: L_Dia = [tbl_Input].Cells(j, 3)
End If
End If
Next
End Sub
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
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 have an extremely large dataset with customer numbers and we cannot just use a =IF(E3=160248, "YES", "NO") to tag a particular customer number of 160248 with YES or NO. Instead, I would like to use VBA code to lookup Customer_Number in column E and return a YES or NO in the corresponding row in Column AG, called Incorporated_160248. I have not done an If then clause in VBA, so I have no idea where to start. Please note, each month the data set can change. One month it could be 4,000 entries and the next 3,500, so that has to be dynamic. Any thoughts?
Sub TagTryco()
Dim CN As Integer, result As String
CN = Range("E:E").Value
If CN = 160248 Then
result = "YES"
Else
result = "NO"
End If
Range("AG:AG").Value = result
End Sub
I get a Compile error: Wrong number of arguments or invalid property assignment.
This CODE Works now:
Sub TagTryco()
Dim listLength
listLength = Worksheets("ILS_Import").Cells(Rows.Count, "E").End(xlUp).Row - 1
Dim i As Integer
For i = 2 To listLength + 2
If Worksheets("ILS_Import").Range("E" & i) = 160248 Then
Worksheets("ILS_Import").Range("AG" & i) = "Yes"
Else
Worksheets("ILS_Import").Range("AG" & i) = "No"
End If
Next
End Sub
To know how many entries you have:
dim listLength
listlength = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row - 1 'I assumed column E, starting at row 2
You need to loop from row 2 to the row 2 + listLength, check the cell in column E, and check if it is equal to your number:
dim i as integer
for i = 2 to listLength + 2
If Range("E" & i) = 160248 Then
Range("AG" & i) = "Yes"
Else
Range("AG" & i) = "No"
End If
Next
If you wish to scan for different numbers you can adapt the code to use a value from a cell in which you enter that number, OR use an inputbox to enter the number you want to look for, or something else. This code was not tested.
If you want to use the column name you assigned instead of AG (which is safer) you can use something along the lines of:
= Range("Incorporated_160248")(i+1)
Instead, which gives the column with an offset of i. Should bring you to the right cell.
I am trying to delete more than one column in my excel sheet.
For Each lvi In ListView1.Items
If lvi.Checked = True Then
arrayLetters = lvi.SubItems(1).Text & ":" & lvi.SubItems(1).Text & "," & arrayLetters
End If
Next
arrayLetters = arrayLetters.Substring(0, arrayLetters.Length - 1)
Dim rg As Excel.Range = xlSheet.Columns(arrayLetters)
rg.Select()
rg.Delete()
The value of arrayLetters is "G:G,F:F". For some reason that doesn't seem to work once it gets there to delete them! Only reason i am doing it this way is so that it doesn't update the table and loop to the other one. In other words, if i delete each one individually then the column moves and the letter will not be the same the next go around.
The error is on the Dim rg As Excel.Range = xlSheet.Columns(arrayLetters) line and it says:
Type mismatch. (Exception from HRESULT: 0x80020005 (DISP_E_TYPEMISMATCH))
Any help would be great!
David
SOLVED
For Each lvi In ListView1.Items
If lvi.Checked = False Then
arrayLetters = lvi.SubItems(2).Text & "," & arrayLetters 'Puts numbers in BACKWORDS
End If
Next
arrayLetters = arrayLetters.Substring(0, arrayLetters.Length - 1)
Dim theNumbers As String() = arrayLetters.Split(",")
Dim num As Integer = 0
xlApp.ScreenUpdating = False
For Each num In theNumbers
xlSheet.Columns(num).delete() 'Deletes columns in reverse order (7,5,4...)
Next
Just delete the lowest numbered column N number of times to reflect how many columns in a row you want to delete. It's better to go off of column numbers rather than letters when dealing with Excel programatically. If you need a code example, let me know and I'll post one.
Edit:
Here is a code example that does what you want:
xlSheet.Columns(i).delete
You want
xlSheet.Range(arrayLetters)
I reckon, that is Range, not Column.
I think the important part to realize (which I didn't initially) is that you have to use numbers for the columns not the letters.