I have a script but it only takes the first value in column D then removes all duplicates. I'm sorry but I'm just learning VBA and need some help. Can this be adjusted or programmed differently to combine all the text values in column D separated by a colon?
To explain we are exporting ticket data and importing to a new tool but their import won't accept duplicates of ticket IDs (numbers, 1000-9000). Our thought is if we can combine the labor descriptions which contains our labor notes then we can retain the data we need and ignore the other info we do not need.
Sub foo()
Dim ws As Worksheet
Dim lstrow As Long
Set ws = Sheets("g1") ' Change to your sheet
With ws
lstrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("B4:M" & lstrow)
.Offset(, 26).FormulaR1C1 = "=IFERROR(INDEX(R4C[-26]:R" & lstrow & "C[-26],MATCH(1,INDEX((R4C1:R" & lstrow & "C1 = RC1)*(R4C[-26]:R" & lstrow & "C[-26] <>""""),),0)),"""")"
ws.Calculate
.Value = .Offset(, 26).Value
.Offset(, 26).ClearContents
End With
With .Range("A4:M" & lstrow)
.Value = .Value
.RemoveDuplicates 1, xlGuess
End With
End With
End Sub
This definitely removes all duplicates but only keeps the first cell value it finds in the secondary column.
Related
I have the macro below runs (no errors) but no results are provided. I have an excel book where duplicates are sometimes found in column "E". Those identified as duplicates should be copied to sheet 2. I know my workbook has duplicates in column E, their just not being copied over.
Sub FilterAndCopy()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range
Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
Application.ScreenUpdating = False
With wstSource
Set rngMyData = .Range("a1:R" & .Range("a" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
.FormulaR1C1 = "=if(countif(c1,RC1)>1,"""",1)"
.Value = .Value
If Evaluate("=COUNTBLANK(" & .Address & ")") > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(2, 1)
.ClearContents
End With
Application.ScreenUpdating = True
End Sub
Because of the cell notation you are using R1C1, your formula
.FormulaR1C1 = "=if(countif(c1,RC1)>1,"""",1)"
refers only to column A
If you want to change your formula to apply on column E, that would be
.FormulaR1C1 = "=if(countif(c5,RC5)>1,"""",1)"
I don't know if your dupplicates are on a single column basis or if should concatenate all your column to see if the entire row is a dupplicate. It might be more simple to apply a sql query connection on this. Pivot tables may also help. If you stick to vba, add additional line for each dupplicate formula and process it in the block of code that copy blank formula to the secondary sheet.
Excel VBA is finding every other cell using a method to check for Empty Cells. On the next time running the same macro, it then finds the cell that it skipped over on the last run while again skipping the next instance of an empty cell. If I cycle through the macro a few times, eventually every row without data is getting deleted, as per the purpose of the macro. The rows do shift upward upon deletion of the row one at a time, I will try a Union and delete the Range as stated by #BigBen
When a cell that is empty is found, it checks columns A, B, and D to see if formula is applied, and if a formula exists in that row, the entire row gets deleted.
Dim cel, dataCells As Range
Dim rngBlank, dc As Range
Dim lastRow, cForm, c, blnkRange As String
Dim cycleTimes As Integer
On Error Resume Next
Set dataCells = Range("F2:W2").Cells 'This is header of the table of data
cycleTimes = dataCells.Count 'Number of times to cycle through macro
For Count = 1 To cycleTimes 'I don't want to cycle through macro
lastRow = Range("N" & Rows.Count).End(xlUp).Row 'To find end of column
For Each dc In dataCells
c = Split(Cells(1, dc.Column).Address, "$")(1) 'Column Letter
blnkRange = c & "3:" & c & lastRow 'Range to look over for empty cells
Set rngBlank = Range(blnkRange).SpecialCells(xlCellTypeBlanks).Cells
For Each cel In rngBlank '**Skipping Every other Row**
If Not TypeName(cel) = "Empty" Then
cForm = "A" & cel.Row & ",B" & cel.Row & ",D" & cel.Row 'Formula check
If Range(cForm).HasFormula Then
cel.EntireRow.Delete
End If
End If
Next
Next
Next
I was able to use Intersect to find the rows that matched the criteria I was searching for and delete the EntireRow even though the Selection was in separate Rows.
Set dataCells = Range("F2:W2").Cells
lastRow = Range("N" & Rows.Count).End(xlUp).Row 'To find last row to generate range to look through
For Each dc In dataCells 'Have to perform delete row for every column
c = Split(Cells(1, dc.Column).Address, "$")(1)
blnkRange = c & "3:" & c & lastRow
Set rngBlank = Range(blnkRange).SpecialCells(xlCellTypeBlanks).EntireRow
strFormula = "A2:A" & lastRow & ",B2:B" & lastRow & ",C2:C" & lastRow
Set rngFormula = Range(strFormula).SpecialCells(xlCellTypeFormulas)
Intersect(rngFormula, rngBlank).EntireRow.Delete (xlShiftUp) '**THIS helped in deleting Rows**
Next
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 have put together a Macro that allows me to archive Data from one sheet to another however I am having trouble having it Clear the info afterwards. The first Column contains numbers that I do not want to clear, right now it is only clearing the data in column B.
If someone could take a look at this I would be very greatful.
'Sub archive()
Dim i, lastrow
Dim mytext As String
lastrow = Sheets("Rooms").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
mytext = Sheets("Rooms").Cells(i, "F").Text
If InStr(mytext, "yes") Then
Sheets("Rooms").Cells(i, "A").EntireRow.Copy Destination:=Sheets("Archive").Range("A" & Rows.Count).End(xlUp).Offset(1)
Sheets("Rooms").Cells(i, "B").Clear
End If
Next i
End Sub'
I've taken the cell on the associated row in column B and extended it to the last cell on the same row containing any value.
Sub archive()
Dim i, lastrow
Dim mytext As String
With WorkSheets("Rooms")
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
mytext = .Cells(i, "F").Text
If InStr(1, mytext, "yes", vbTextCompare) Then
.Cells(i, "A").EntireRow.Copy Destination:=Sheets("Archive").Range("A" & Rows.Count).End(xlUp).Offset(1)
.Range(.Cells(i, "B"), .Cells(i, Columns.Count).End(xlToLeft)).Clear
End If
Next i
End With
End Sub
Additionally, I've used a With ... End With statement to associate WorkSheets("Rooms") with all of its cells to avoid repetitive worksheet referencing.
The Range.Clear command scrubs all values and formatting. If you just want the values to be removed, you may want to switch to Range.ClearContents method.
I have a excel table which looks like this one.
As you can see, this products 2005 and 3004 are listed more than once because this same products have different price value based on sale scala. Like, if you buy 50 each of that item, the price gets lower.
What I want is -assuming there is a way to achieve- is this :
ProductID Column is Unique and entrys with same product ID gathers on 1 row. With their Sale Scala and Price(Per) values added(if there is) within next columns. Is there a solution to alter the table like this with coding ? There is too much line to manually edit.
Please Suggest. Thanks.
There are probably better ways to do this but I've created a simple loop that looks for duplicate values in column A then processes the data accordingly. I'm working bottom up for simplicity. Note: You'll have to manually create your headers when finished unless you want to add more logic.
EDIT Simpler code
Sub TransposeData()
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Sheet1")
With WS
Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumber = LastCell.Row
End With
'Loop through column A bottom up
For i = LastCellRowNumber To 2 Step -1
' Check if value in current cell matches value in cell above it
If (Range("A" & i).Value = Range("A" & i).Offset(-1, 0).Value) Then
'Shift current values over
Range("C" & i & ":D" & i).Insert Shift:=xlToRight
'Copy new values down
Range("C" & i).Value = Range("C" & i - 1).Value
Range("D" & i).Value = Range("D" & i - 1).Value
'Delete row
Rows(i - 1).Delete Shift:=xlUp
End If
Next i
End Sub
Results: