I've seen similar posts out there but not quite the same and seem to be confused on the results I'm getting...
I essentially need to de-dupe a column on LIKE words, so it's somewhat straightforward but apparently not as easy as I thought.
I have a dataset like soo...
When I run my macro it removes rows (as I intended), but doesn't seem to remove all the rows or the wrong rows...
It actually removes the highlighted/yellow rows
I was thinking it should actually remove something like the bottom rows.. where it would keep "aerospace" but remove "aerospace 2019", since the 2019 is kinda redundant and not applicable to me.
My macro is simple, but I thought it would do the trick... what am I doing wrong?
Sub container()
Dim ws As Worksheet, rw As Long, col As Long, i As Long
Set ws = ActiveSheet 'or whatever
i = 2
'For col = 2 To 5 'placeholder in case multiple columns are needed - remove Set col above
For rw = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row 'from row 1 til last non-empty row
v = ws.Cells(rw, 2).Value 'set range
If Cells(i, 2).Value Like v Then 'determine if the cell contains the value of the word
Cells(i, 2).EntireRow.Delete 'delete
i = i + 1
End If
Next rw
'Next col
End Sub
After Ron's post I was able to create the below, but appears I'm still stuck. I think I've just been looking at this too long.
Sub container()
Dim ws As Worksheet, rng As Range, i As Long, rw As Long
Set ws = ActiveSheet 'or whatever
Set rng = ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) 'set array range
i = Range("B" & Rows.Count).End(xlUp).Row
For rw = ws.Cells(Rows.Count, 1).End(xlDown).Row To 2
v = ws.Cells(rw, 2).Value
If InStr(1, v, rng) > 0 Then
cell.EntireRow.Delete
i = i - 1
End If
Next rw
End Sub
Related
I'm not sure whether it's because I'm using a mac or the code is wrong, but the rows aren't identifying properly, and therefore not deleting or pasting it into the other spreadsheet. I have to run the code three times for it to properly go through it and copy/paste and delete the cells into the other spreadsheet.
Many thanks!
here is the code:
Dim j, lastidno As Long
Sheets("Part B + C Modules").Activate
lastidno = Range("A2", Range("A2").End(xlDown)).Count + 1
For j = 2 To lastidno
If Range("O" & j) = "" Then
Sheets("Part B + C Modules").Range("A" & j).Copy
Sheets("No Options Selected").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Part B + C Modules").Activate
Rows(j).EntireRow.Delete
End If
Next
MsgBox "done"
End Sub
Iteration and deleting rows goes backwards using a negative Step > For j = lastidno to 2 Step -1
However, it appears you could rewrite your code a bit more elegantly to avoid:
Implicit Range references
Iteration
Use of Activate or Select
The key is to have Explicit sheet references to work with. Also the use of SpecialCells can come in handy here to return a Range in one go (so no more iteration). This way you can also delete all rows in one go!
You code could, for example, look like:
Sub Test()
'Set up your worksheet variables
Dim ws1 As Worksheet: Set ws1 = Worksheets("Part B + C Modules")
Dim ws2 As Worksheet: Set ws2 = Worksheets("No Options Selected")
'Get last used rows
Dim lr1 As Long: lr1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Dim lr2 As Long: lr2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
'Set your range and copy it
Dim rng As Range: Set rng = ws1.Range("O2:O" & lr1).SpecialCells(xlCellTypeBlanks).Offset(0, -14)
rng.Copy ws2.Cells(lr2 + 1, 1)
'Delete your range
rng.EntireRow.Delete
MsgBox "done"
End Sub
Small catch: SpecialCells will return an error when no empty cells are found. You might want to work your way around that using On error or count the empty cells in your Range first (my personal preference). So that specific part could looke like:
'Set your range and copy it
If WorksheetFunction.CountBlank(ws1.Range("O2:O" & lr1)) > 0 Then
Dim rng As Range: Set rng = ws1.Range("O2:O" & lr1).SpecialCells(xlCellTypeBlanks).Offset(0, -14)
rng.Copy ws2.Cells(lr2 + 1, 1)
End If
Another small note for future reference: Dim j, lastidno As Long only has lastidno declared as Long data type. j Variable is auto-assigned to Variant/Integer so could potentially become a problem when your data is larger than this data type can hold > Return an OverFlow error.
I have some code in VBA that is attempting to delete duplicate transaction IDs. However, i'd like to ammend the code to only delete duplicates that have a transaction ID - so, if there is no transaction ID, i'd like that row to be left alone. Here is my code below:
With MySheet
newLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
newLastCol = .Cells(5 & .Columns.Count).End(xlToLeft).Column
Set Newrange = .Range(.Cells(5, 1), .Cells(newLastRow, newLastCol))
Newrange.RemoveDuplicates Columns:=32, Header:= _
xlYes
End With
I was also wondering - in the remove.duplicates command - is there a way where I can have the column I want looked at to be named rather than have it be 32 in case I add or remove columns at a later date?
Here is an image of the data: I'd like the ExchTransID column that have those 3 blank spaces to be left alone.
Modify and try the below:
Option Explicit
Sub test()
Dim Lastrow As Long, Times As Long, i As Long
Dim rng As Range
Dim str As String
'Indicate the sheet your want to work with
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row with IDs
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set the range with all IDS
Set rng = .Range("A1:A" & Lastrow)
'Loop column from buttom to top
For i = Lastrow To 1 Step -1
str = .Range("A" & i).Value
If str <> "" Then
Times = Application.WorksheetFunction.CountIf(rng, str)
If Times > 1 Then
.Rows(i).EntireRow.Delete
End If
End If
Next i
End With
End Sub
I am working with a dataset that is refreshed when a sharepoint survey is completed, and the responses to that survey are then exported to a table in Excel. I want to be able to delete an entire row(s) if the ZIP code (string) of the facility reviewed (Column Y) is the same, but I want to keep the most-recent survey response, or that which appears in the higher row value.
For example, row 38 contains a survey response with a ZIP code string of "33138." Row 52 (survey completed more-recently), was also completed for ZIP code "33138." I want to delete row 38, and retain row 52.
Looking for a VBA solution.
#BigBen I've tried this code, which I found on a few discussion boards. Also note, I plan run this from a button on "Dashboard" tab for records on the "data" tab.
Sub deduplicate()
Dim Rng As Range, Dn As Range, n As Long
Dim Lst As Long, nRng As Range
Lst = Range("Y" & Rows.Count).End(xlUp).Row
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For n = Lst To 1 Step -1
If Not .Exists(Range("Y" & n).Value) Then
.Add Range("Y" & n).Value, Nothing
Else
If nRng Is Nothing Then
Set nRng = Range("Y" & n)
Else
Set nRng = Union(nRng, Range("Y" & n))
End If
End If
Next n
If Not nRng Is Nothing Then nRng.EntireRow.Delete
End With
End Sub
#BigBen, as part of a longer script, I also tried the following code. It sort of worked, but only removed the first instance of a duplicate, and not all duplicate rows.
Worksheets("Data").Activate
Dim lrow As Long
For lrow = Cells(Rows.Count, "Y").End(xlUp).Row To 2 Step -1
If Cells(lrow, "Y") = Cells(lrow, "Y").Offset(-1, 0) Then
Cells(lrow, "Y").Offset(-1, 0).EntireRow.Delete
End If
Next lrow
Based on your comment that the data is in a table (ListObject), something like this could work. This loops from the first to last row, deleting the row if a CountIf on the column, using the current row's value, is greater than 1.
Sub DedupeZipCodes()
Dim tbl As ListObject: Set tbl = ThisWorkbook.Sheets("Data").ListObjects("Table1")
Dim zipCol As ListColumn: Set zipCol = tbl.ListColumns("Zip Code")
Dim currentRow As Long, lastRow As Long
With zipCol
currentRow = 1
lastRow = .DataBodyRange.Rows.Count
Do While currentRow < lastRow
If Application.CountIf(.DataBodyRange, .DataBodyRange(currentRow).Value) > 1 Then
.DataBodyRange(currentRow).EntireRow.Delete
lastRow = .DataBodyRange.Rows.Count
Else
currentRow = currentRow + 1
End If
Loop
End With
End Sub
I have one excel sheet (lets say sheet A) that has data in it, organized into groupings separated by an empty row and grouped by a common entry in column N. Within each grouping, I need to check another excel sheet (lets say sheet B) in a different workbook to see if any of the entries in column A of sheet A matches any entries in sheet B's column C. If any of the column C entries match those of the column A entries in a single grouping of the first sheet, I do not do anything to that grouping. If there are no matches, I need to delete the whole grouping. Below is my attempt, but I am mostly getting confused with 1. how to delete just a grouping and 2. how to call to each sheet/column correctly.
Sub DeleteAdjacent()
Dim wb1 As Workbook, Dim wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
Dim lastrow1 As Long, Dim lastrow2 As Long, Dim i As Long, Dim j As Long
Set wb1 = Workbooks("Workbook1.xlsx")
Set wb2 = Workbooks("Workbook2.xlsx")
Set sh2 = wb2.Sheets(“Sheet B”)
Set sh1 = wb1.Sheets("Sheet A")
lastrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
For j = lastrow1 To 1 Step -1
cell = "N" & j
cell1 = "N" & (j - 1)
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
For i = lastrow2 To 1 Step -1
cell2 = "C" & i
cell3 = "A" & j
If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range(j, cell).EntireRow.Delete
Loop
End If
Next i
Loop
Next j
End Sub
Edit: Looking at my attempt more closely, it would actually do the opposite of what I'd want to do. I attempted to delete the entire grouping when there was a match, when I actually want the exact opposite. I think then the part below should be changed.
If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range.Cells(j, cell).EntireRow.Delete
Loop
End If
My attempt at correcting this is maybe too simple?
If sh1.Cells(j, cell3).Value <> sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range.Cells(j, cell).EntireRow.Delete
Loop
End If
I think if I were attacking this problem I wouldn't compare A with C and do the group looping check in the same process. It might be easier to get your head around the issue if you create a map of values to groups first. Say a value of 10 exists in groups 1,3 and 5, then you could just check for a 10 and immediately eliminate 3 groups from your future checks. A Collection of Collections would serve you well for this as the look up by key is very fast and you don't have to worry about the number of items it stores.
If you also had a collection of Ranges for each group then it would be a simple process of eliminating matching groups and then, in one hit, delete all the remaining Ranges.
The code below should do that for you (but as with any row delete code, I'd suggest you back up your raw data first!):
Public Sub DeleteAdjacent()
Dim ws As Worksheet
Dim valueGroupMap As Collection
Dim groupRanges As Collection
Dim values As Collection
Dim lastRow As Long
Dim groupRng As Range
Dim valueCell As Range
Dim groupCell As Range
Dim rng As Range
Dim v As Variant
Dim r As Long
'Read the Column A worksheet
Set ws = Workbooks("Workbook1.xlsx").Worksheets("Sheet A")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1 '+1 to get a blank row at end
'Define the value map group ranges
Set valueGroupMap = New Collection
Set groupRanges = New Collection
Set groupRng = ws.Cells(1, "N")
For r = 1 To lastRow
Set valueCell = ws.Cells(r, "A")
Set groupCell = ws.Cells(r, "N")
If Len(CStr(groupCell.Value2)) = 0 Then
'We've reached the end of a group
Set rng = ws.Range(groupRng, groupCell.Offset(-1))
groupRanges.Add rng, CStr(groupRng.Value2)
Set groupRng = Nothing
Else
'We're working within a group
If groupRng Is Nothing Then
Set groupRng = groupCell
End If
'Create the value to group map
Set values = Nothing
On Error Resume Next
Set values = valueGroupMap(CStr(valueCell.Value2))
On Error GoTo 0
If values Is Nothing Then
Set values = New Collection
valueGroupMap.Add values, CStr(valueCell.Value2)
End If
values.Add CStr(groupRng.Value2)
End If
Next
'Read the Column C worksheet
Set ws = Workbooks("Workbook2.xlsx").Worksheets("Sheet B")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For r = 1 To lastRow
'Check if we have the value
Set values = Nothing
Set values = valueGroupMap(CStr(ws.Cells(r, "C").Value2))
If Not values Is Nothing Then
'We do, so remove the group ranges from our list
For Each v In values
groupRanges.Remove CStr(v)
Next
End If
Next
On Error GoTo 0
'Create a range of the groups still remaining in the list
Set rng = Nothing
For Each groupRng In groupRanges
If rng Is Nothing Then
Set rng = groupRng
Else
Set rng = Union(rng, groupRng)
End If
Next
'Delete that range
rng.EntireRow.Delete
End Sub
I pasted the entire macro below but this is the important part.
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
It works as is except it is creating unnecessary data because I don't know how to use variable names in a range object. My ranges are currently hard coded such as ("A1:A1000"), when I would like it to be something like ("A1:A & LastRow).
Also I have to explicitly call out column names to copy because the range won't accept a variable name like ("currentColumn & 1:currentColumn & LastRow).
Is there a way to use a varible name as part of a range object so we can use them in loops?
Sub prepareWorkbook()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")
If Columns(answer).Column = 1 Then
Else
'cut Id column from current location and insert it at column index 1
Columns(answer).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next
' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2
'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
Columns(colx).Insert Shift:=xlToRight
Next
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")
End Sub
Assuming the you are running code in the Worksheet added here:
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
Also not sure what is the purpose of this code, nevertheless using it for the sample
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Try this:
Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row
Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
With wbk.Worksheets(MySheetName)
Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next
Something like:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value
Although this answer won't be applied to your situation, I feel like this could help answer some questions you have in there.
When specifying a range, you can separate the column (letter) and row (number) and use your own variables.
In a for loop, this could look like
for i = 1 to 100
Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next
You can also determine the number of the row of the selected cell using:
dim RowNb as long
RowNb = (ActiveCell.Row)
This also applies to columns, and can be used in a loop like I mentionned at the start.
The one thing that was conspicuous by its absence in your description was any mention of the nature of the data in the worksheet. You mentioned A1 briefly but your range value assignments started at row 2 so it may be inferred that row 1 contains column header labels.
Sub prepareWorkbook()
Dim wbk As Workbook, wks As Worksheet
Dim colx As Long
Dim lc As Long, lr As Long
Dim MySheetName As String
Set wbk = ThisWorkbook 'no idea what this does
Set wks = wbk.ActiveSheet 'no idea what this does
MySheetName = "Import"
'no idea what this does or what sht is
'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
With Sheets(2)
.Name = MySheetName
If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
colx = Application.Match("PartNumber", .Rows(1), 0)
Else
colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
End If
If .Columns(colx).Column > 1 Then
'cut Id column from current location and insert it at column index 1
.Columns(colx).Cut
.Columns(1).Insert Shift:=xlToRight
End If
'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
With .Columns(1)
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
End With
' insert column every other column (working backwards toward A1)
For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
.Columns(lc).Insert Shift:=xlToRight
Next lc
For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
'let's put the row-by-row value in instead of a single value into all cells
lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
With .Cells(2, lc).Resize(lr - 1, 1)
.Cells = .Offset(-1, 1).Value
.EntireColumn.AutoFit
End With
Next lc
End With
Set wbk = Nothing
Set wks = Nothing
End Sub
Explanations as comments in code.