I have two sheets in a workbook. They are imported (connected) from two text file reports. Right now the code I'll post below deletes all duplicates between the two sheets and leaves me with the first sheet (today) with just unique rows left. The problem is Column A, which I use to compare and delete contains words on some lines (like "Category") and numbers on other lines. The only duplicates I really need deleted are the numeric duplicates. I would prefer the words get ignored. Is there a way to delete duplicate rows with numeric values and ignore letter values? I haven't been able to find anything and I honestly don't do this stuff often.
Sub CleanDupes()
Application.ScreenUpdating = False
Dim targetArray, searchArray, targetRange As Range, x As Long
'Update these 4 lines if your target and search ranges change
Dim TargetSheetName As String: TargetSheetName = "Today"
Dim TargetSheetColumn As String: TargetSheetColumn = "A"
Dim SearchSheetName As String: SearchSheetName = "Yesterday"
Dim SearchSheetColumn As String: SearchSheetColumn = "A"
'Load target array
With Sheets(TargetSheetName)
Set targetRange = .Range(.Range(TargetSheetColumn & "12"), _
.Range(TargetSheetColumn & Rows.Count).End(xlUp))
targetArray = targetRange
End With
'Load Search Array
With Sheets(SearchSheetName)
searchArray = .Range(.Range(SearchSheetColumn & "12"), _
.Range(SearchSheetColumn & Rows.Count).End(xlUp))
End With
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
'Populate dictionary from search array
If IsArray(searchArray) Then
For x = 1 To UBound(searchArray)
If Not dict.exists(searchArray(x, 1)) Then
dict.Add searchArray(x, 1), 1
End If
Next
Else
If Not dict.exists(searchArray) Then
dict.Add searchArray, 1
End If
End If
'Delete rows with values found in dictionary
If IsArray(targetArray) Then
'Step backwards to avoid deleting the wrong rows.
For x = UBound(targetArray) To 1 Step -1
If dict.exists(targetArray(x, 1)) Then
targetRange.Cells(x).EntireRow.Delete
End If
Next
Else
If dict.exists(targetArray) Then
targetRange.EntireRow.Delete
End If
End If
End Sub
Related
I currently have an array built to where I have all the columns I need to build a table. However, I am having trouble splitting up this array to match the according values.
In order to build this array, I am extracting the data from this table as seen in sheet2 labeled "Current Drawing Text"
Next, I am trying to build a new table based off of the data in sheet2 onto sheet sheet3 (labeled "Wire Checker"), this time using the cables to match which drawing number that they are on. This table currently looks something like this:
I have the array broken up by cable name. I just am unsure on how I would be performing the matches from the cables to the drawing number. I tried using formulas to "test", but without any luck. This is the code that I have tried so far:
Sub Searchalltest()
Dim WireCheckerWorksheet As Worksheet
Dim DrawingLastRow As Long
Dim CableLastRow As Long
Dim DrawingandCableRange As Range
Dim CurrentDrawingTextWorksheet As Worksheet
Dim DrawingTableArray
Dim DrawingNumber As Long
Dim CableNumber
Dim ArrayStart
Set WireCheckerWorksheet = ThisWorkbook.Worksheets("Wire Checker")
'Temporary Varaiables
Dim Row As Long
Row = 20
Dim Column_D As Integer
Column_D = 4
'End of Temporary variables
Dim dict As New Scripting.Dictionary
Set CurrentDrawingTextWorksheet = ThisWorkbook.Worksheets("Current Drawing Text")
DrawingLastRow = CurrentDrawingTextWorksheet.Range("C" & CurrentDrawingTextWorksheet.Rows.Count).End(xlUp).Row 'last row to be calculated for every drawing the entry
DrawingTableArray = CurrentDrawingTextWorksheet.Range("C20:G" & DrawingLastRow).Value
For DrawingNumber = 1 To UBound(DrawingTableArray) 'iterate between the array rows number:
ArrayStart = Split(DrawingTableArray(DrawingNumber, 5), vbLf) 'split the cells content on the line separator
For Each CableNumber In ArrayStart 'iterate between the splited array elements:
If Not dict.Exists(CableNumber) Then 'put the array elements in a dictionary (as unique keys)
dict.Add CableNumber, DrawingTableArray(DrawingNumber, 1) 'the item is the value in array col 1 (Group 1, 2, 3...)
Else
dict(CableNumber) = dict(CableNumber) & "|" & DrawingTableArray(DrawingNumber, 1) 'add to the key value the other Groups, separated by "|"
End If
Next CableNumber
Next DrawingNumber
Dim ArrayFinal
For Each CableNumber In dict
With Worksheets("Wire Checker")
Debug.Print CableNumber
.Cells(Row, Column_D).Value = CableNumber
Row = Row + 1
End With
Next
'Now let's sort the cables
Dim WireCheckerWorksheetCableLastRow As Long
WireCheckerWorksheetCableLastRow = Cells(Rows.Count, Column_D).End(xlUp).Row
Range("A20:D" & WireCheckerWorksheetCableLastRow).Sort key1:=Range("D20:D" & WireCheckerWorksheetCableLastRow), order1:=xlAscending, Header:=xlNo
End Sub
I am using an IF statement in Excel to search for portions of text in the previous column in order to assign a supplier and category to the expense.
Supplier Column
=IF(ISNUMBER(SEARCH("tit",[#Description])),"TITAN",IF(ISNUMBER(SEARCH("Sol",[#Description])),"Soltrack",IF(ISNUMBER(SEARCH("coin",[#Description])),"Coin",IF(ISNUMBER(SEARCH("gree",[#Description])),"Green Dream Projects",IF(ISNUMBER(SEARCH("sars V",[#Description])),"SARS VAT",IF(ISNUMBER(SEARCH("sars p",[#Description])),"SARS PAYE",IF(ISNUMBER(SEARCH("acb",[#Description])),"Debit Order","")))))))
Category Column
the next column then has the following to get the category of the supplier
=IF(ISNUMBER(SEARCH("TITAN",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Soltrack",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Coin",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Green Dream Projects",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("SARS VAT",[#Payee])),"VAT",IF(ISNUMBER(SEARCH("SARS PAYE",[#Payee])),"PAYE",IF(ISNUMBER(SEARCH("Debit Order",[#Payee])),"Debit Order","")))))))
this is working great, but seems i have reached the limit (7) of IF statements I can use in one formula?
I have created the below function to search for text "tit" and if it matches it updates the Payee column.
'excel if range of cells contains specific text vba
Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Set Rng = Range("B2:B572") ' You can change this
specificText = "*tit*" ' You can change this
For Each Cell In Rng.Cells
If UCase(Cell.Value) Like "*" & UCase(specificText) & "*" Then
Cell.Offset(0, 1) = "Titan"
Else
Cell.Offset(0, 1) = ""
End If
Next
End Sub
Would I need to create a new specificText = "*tit*" for each of the keywords and also a whole section for each of the "For Each" functions?
Dictionary Solution
The first idea is to use a dictionary Replacements and add all the serach/replace pairs there. This has one huge disadvantage. It is against the good practice to not mix logic (code) and data. Good practice would be to put the data not into the code but into a worksheet (see next solution).
Option Explicit
Public Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements As Object
Set Replacements = CreateObject("Scripting.Dictionary")
With Replacements
.Add "tit", "Titan"
.Add "sol", "Soltrack"
'add more here
End With
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim Key As Variant
For Each Key In Replacements.Keys
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Key) & "*" Then
OutputValues(iRow, 1) = Replacements(Key)
Exit For 'we don't need to test for the others if we found a key
End If
Next Key
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
Worksheet Solution
The better solution would be to create a new worksheet Replacements as below:
This can easily be edited by anyone and you don't need to fiddle with the code later if you want to delete or add pairs.
Public Sub ImprovedCheckUsingWorksheet()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements() As Variant 'read replacements from worksheet
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "B").End(xlUp)).Value 'read input values into array
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim rRow As Long
For rRow = 1 To UBound(Replacements, 1)
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Replacements(rRow, 1)) & "*" Then
OutputValues(iRow, 1) = Replacements(rRow, 2)
Exit For 'we don't need to test for the others if we found a key
End If
Next rRow
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
For a 3ʳᵈ column in your replacements worksheet you would need to adjust the following line to be until column "C":
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "C").End(xlUp)).Value 'read input values into array
and the output values need another column too (second parameter needs to go 1 To 2):
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To UBound(Replacements, 2) - 1) 'this works for any amount of columns as it reads the column count from the `Replacements`
the data needs to be written
OutputValues(iRow, 1) = Replacements(rRow, 2) 'first output column
OutputValues(iRow, 2) = Replacements(rRow, 3) 'second output column
and writing the output values needs to be adjusted too:
RngToCheck.Offset(ColumnOffset:=1).Resize(ColumnSize:=UBound(OutputValues, 2)).Value = OutputValues 'this works for any amount of columns as it reads the column count from `OutputValues`
Formula Solution
But if you have your data in a worksheet Replacements like above, and you don't rely an a partial match. Then you don't need VBA and can easily use a formula instead to look it up:
=IFERROR(INDEX(Replacements!B:B,MATCH(B:B,Replacements!A:A,0)),"")
i'm new to excal macros/vba, and i am encountering a problem which i do not know how to approach.
I have a workbook that includes several sheets. There is 1 file which is more or less a master list, and 3 files which are sort of a packing list.
I have put in a command button with a macro in the 3 packing list respectively that tells me if a certain item in the packing list exist in the master, and if it does it tells me which row it appears in. This is working fine, however my problem is that if a particular items appears several times in the master list(due to different purchase date), the macro only gives the first result.
I would like to know if there are any ways such that all possible results appears instead of just the first.
below is a sample of the code i used
Private Sub CommandButton1_Click()
Dim k As Integer
For k = 3 To 1000
Cells(k, 24).Value = Application.Match(Cells(k, 2), Sheets("master").Range("B2:B1000"), 0)
Next k
End Sub
if your "master" sheet data is a list of contiguous not empty cells from B2 down to last not empty one, then here's a different approach playing around a bit with
Option Explicit
Private Sub CommandButton1_Click()
Dim cell As Range
With Worksheets("master") ' reference your "master" sheet
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)) ' reference referenced sheet column B range from row 2 down to last not empty one
For Each cell In Range("B3", Cells(Rows.Count, "B").End(xlUp)) ' loop through packinglist sheet (i.e. where button resides) column B cells from row 3 down to last not empty one
If Not .Find(what:=cell.Value2, LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then ' if current packinglist item is in "master"
.Replace what:=cell.Value2, replacement:=vbNullString, lookat:=xlWhole ' temporarily replace master item with a blank
cell.Offset(, 22).Value2 = Replace(.SpecialCells(xlCellTypeBlanks).Address(False, False), "B", "") ' write master list blanks rows in packinglist sheet current item row and column "X"
.SpecialCells(xlCellTypeBlanks).Value = cell.Value2 ' restore master list current packinglist item value
End If
Next
End With
End With
End Sub
I would use a dictionary to store every item in the master sheet, and everytime you find it duplicate, add another number with its row like this:
Option Explicit
Private Sub CommandButton1_Click()
Dim MasterKeys As Object
MasterKeys = FillDictionary(MasterKeys)
With ThisWorkbook.Sheets("MySheet") 'change MySheet for your actual sheet name
Dim arr As Variant
arr = .UsedRange.Value 'drop your data inside an array
Dim i As Long
For i = 3 To UBound(arr) 'loop through all the rows in your data
If MasterKeys.Exists(arr(i, 2)) Then arr(i, 24) = MasterKeys(arr(i, 2))
Next i
.UsedRange.Value = arr 'drop back your data
End With
End Sub
Function FillDictionary(MasterKeys As Object) As Object
Set MasterKeys = CreateObject("Scripting.Dictionary")
With Workbooks("MasterWorkbook.xlsx").Sheets("master") 'change MasterWorkbook for the actual filename of your master workbook
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'find the last row on column B
Dim C As Range
For Each C In .Range("B2:B" & LastRow) 'loop through the range
If Not MasterKeys.Exists(C.Value) Then
MasterKeys.Add C.Value, C.Row
Else
MasterKeys(C.Value) = MasterKeys(C.Value) & "," & C.Row
End If
Next C
End With
End Function
I want to compare the Sheet1 column A values with Sheet2 column B, if match then i want to put the Sheet1 Column A values in Sheet2 Column C.
and column D should be populated with 'True'
So i have written the below code:
Sub val()
Dim sheet1_last_rec_cnt As Long
Dim sheet2_last_rec_cnt As Long
Dim sheet1_col1_val As String
Dim cnt1 As Long
Dim cnt2 As Long
sheet1_last_rec_cnt = Sheet1.UsedRange.Rows.Count
sheet2_last_rec_cnt = Sheet2.UsedRange.Rows.Count
For cnt1 = 2 To sheet1_last_rec_cnt
sheet1_col1_val = Sheet1.Range("A" & cnt1).Value
For cnt2 = 2 To sheet2_last_rec_cnt
If sheet1_col1_val = Sheet2.Range("B" & cnt2).Value Then
Sheet2.Range("C" & cnt2).Value = sheet1_col1_val
Sheet2.Range("D" & cnt2).Value = "True"
Exit For
End If
Next
Next
End Sub
Problem is i have one millions of records in both the sheets.
if i use the above code then For loop is running (One million * One million) times. So excel is hanging like anything.
Can someone please help me to optimize the code?
For 1 million records I'm not sure Excel is the best place to be storing this data. If your code is designed to tidy up the data so that you can export it to a database then great ... if not, then, well, I fear rough seas lay ahead for you.
The code below will speed things up a touch as it only loops through each column once, and it populates a collection of unique values so that it only has to check against that instead of the whole column each time. If you sorted your rows then it could be made even quicker but I'll leave that one for you.
Public Sub RunMe()
Dim uniques As Collection
Dim sourceValues As Variant
Dim targetValues As Variant
Dim sourceItem As String
Dim targetItem As String
Dim sourceCount As Long
Dim targetCount As Long
Dim matches As Boolean
Dim output() As Variant
' Acquire the values to be compared.
With ThisWorkbook.Worksheets("Sheet1")
sourceValues = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
targetValues = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
'Resize the output array to size of target values array.
ReDim output(1 To UBound(targetValues, 1), 1 To 2)
sourceCount = 1
Set uniques = New Collection
'Iterate through the target values to find a match in the source values
For targetCount = 1 To UBound(targetValues, 1)
targetItem = CStr(targetValues(targetCount, 1))
matches = Contains(uniques, targetItem)
If Not matches Then
'Continue down the source sheet to check the values.
Do While sourceCount <= UBound(sourceValues, 1)
sourceItem = CStr(sourceValues(sourceCount, 1))
sourceCount = sourceCount + 1
'Add any new values to the collection.
If Not Contains(uniques, sourceItem) Then uniques.Add True, sourceItem
'Check for a match and leave the loop if we found one.
If sourceItem = targetItem Then
matches = True
Exit Do
End If
Loop
End If
'Update the output array if there's a match.
If matches Then
output(targetCount, 1) = targetItem
output(targetCount, 2) = True
End If
Next
'Write output array to the target sheet.
ThisWorkbook.Worksheets("Sheet2").Range("C2").Resize(UBound(targetValues, 1), 2).value = output
End Sub
Private Function Contains(col As Collection, key As String) As Boolean
'Function to test if the key already exists.
Contains = False
On Error Resume Next
Contains = col(key)
On Error GoTo 0
End Function
I have been trying to create a simple macro that takes all duplicate records from a source sheet and pastes them into a new sheet.
I have been messing around, and the closest I've gotten is the creation of a list that extracts all duplicate values except for the first duplicate value in a cluster.
So for example, if a list looks like this below:
1
1
2
3
4
5
1
The sheet with the duplicates will list:
1
1
It will consider the first instance of '1' as unique, and that is totally not what I want. I want it to show every single instance of the duplicated row, so I awnt this:
1
1
1
Here's what I do to deal with duplicates. It isn't a macro, but works for me:
Sort the column with the duplicate. (For this example, say column C)
In a new column, write an IF function. Eg in cell D5: =if(c5=c4,1,"")
Copy cell D5 to the entire list.
Copy and paste value column D over itself. Eg in step 2, the formula is replaced with a "1"
Sort column D
Any row with a 1 is a duplicate. Do as you wish!
You can also do things like find the sum of column D (shows me how many duplicates)
After clarifications by OP the following procedure will perform as required:
Sub CopyDuplicates()
'***************************************************************
'** This proc expects you to select all the cells in a single **
'** column that you want to check for duplicates in. If dup- **
'** licates are found, the entire row will be copied to the **
'** predetermined sheet. **
'***************************************************************
Dim ShO As Worksheet
Dim Rng1 As Range
Dim pRow As Integer
Dim c As Range, cTmp As Range
Dim found
Dim Addresses() As String
Dim a() As String
Dim p2 As Integer
Dim tfFlag As Boolean, sTmp As Variant
Set ShO = Worksheets("Sheet2") 'You can change this to whatever worksheet name you want the duplicates in
Set Rng1 = Application.Selection 'Rng1 is all the currently selected cells
pRow = 1 'This is the first row in our outpur sheet that will be used to record duplicates
ReDim a(0) 'Initialize our array that holds found values
For Each c In Rng1.Cells 'Cycle through each cell in our selected range
ReDim Addresses(0) 'This array holds the cell address for our duplicates.
'We will reset the array each time we move to the next cell
'Now check the array of already found duplicates.
'If the current value is already there skip to next value
tfFlag = False
For Each sTmp In a
If CStr(c.Value) = sTmp Or CStr(c.Value) = "xXDeleteXx" Then 'We've already done this value, move on
tfFlag = True
Exit For
End If
Next
If Not tfFlag Then 'Remember the flag is true when we have already located the
'duplicates for this value, so skip to next value
With Rng1
Set found = .Find(c.Value, LookIn:=xlValues) 'Search entire selected range for value
If Not found Is Nothing Then 'Found it
Addresses(0) = found.Address 'Record the address we found it
Do 'Now keep finding occurances of it
Set found = .FindNext(found)
If found.Address <> Addresses(0) Then
ReDim Preserve Addresses(UBound(Addresses) + 1)
Addresses(UBound(Addresses)) = found.Address
End If
Loop While Not found Is Nothing And found.Address <> Addresses(0) 'Until we get back to the original address
If UBound(Addresses) > 0 Then 'We Found Duplicates
a(UBound(a)) = c.Value 'Record the value we found a duplicate for in an array
ReDim Preserve a(UBound(a) + 1) 'add an empty spot to the array for next value
ShO.Range("A" & pRow).Value = "Duplicate Rows for Value " & c.Value & _
" in Column " & c.Column & " on original sheet" 'Add a label row
pRow = pRow + 1 'Increment to the next row
For p2 = UBound(Addresses) To 0 Step -1 'Cycle through the duplicate addresses
Set cTmp = Rng1.Worksheet.Range(Addresses(p2)) 'we just want to easily get the correct row to copy
Rng1.Worksheet.Rows(cTmp.Row).Copy ShO.Rows(pRow) 'Copy form orig to duplicates sheet
cTmp.Value = "xXDeleteXx" 'Mark for Delete the original row
pRow = pRow + 1 'Increment row counter
Next p2
pRow = pRow + 1 'This increment will give us a blank row between sets of dupicates
End If
End If
End With
End If
Next
'Now go delete all the marked rows
Do
tfFlag = False
For Each c In Rng1
If c.Value = "xXDeleteXx" Then
Rng1.Worksheet.Rows(c.Row).Delete (xlShiftUp)
tfFlag = True
End If
Next
Loop Until tfFlag = False
End
End Sub