Im trying to detect duplicates on column("G") of my input workbook and by using lastrow of its data at column("E") to merge upwards by using & "" & after which it will delete the entireRow and this process continue until there are no more duplicates.
I tried and also look up for many codes including delete and duplicates but I am still having trouble.
Dim myCell As Range, myRow As Integer, myRange As Range, myCol As Integer, X As Integer
'Count number column
Set wsInput = Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112")
myCol = Range(Cells(3, 7), Cells(3, 7).End(xlDown)).Count
'Loop each column to check duplicate values & highlight them.
For X = 3 To myRow
Set myRange = Range(Cells(2, X), Cells(myRow, X))
For Each myCell In myRange
If Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112").CountIf(myRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 3
End If
Next
Next
' allow values at Column"E" to merge upwards and delete all duplicate and its row (missing)
I have no clue how to delete after copying data on top of the column. Someone please help.
Many Thanks,
Adrian
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, y As Long, Counter As Long
Dim SearchValue As String, AddValue As String
With ThisWorkbook.Worksheets("Sheet1") ' Always select your worksheet name
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Counter = 0
AddValue = ""
SearchValue = ""
For i = LastRow To 3 Step -1
SearchValue = .Range("C" & i).Value
If SearchValue <> "" Then
If Application.WorksheetFunction.CountIf(.Range("C3:C" & LastRow), SearchValue) > 1 Then
For y = i To 3 Step -1
If .Range("C" & y).Value = SearchValue Then
If AddValue = "" Then
AddValue = .Range("E" & y).Value
Else
AddValue = AddValue & ", " & .Range("E" & y).Value
.Rows(y).EntireRow.Delete
Counter = Counter + 1
End If
End If
Next y
.Range("E" & i - Counter).Value = AddValue
AddValue = ""
SearchValue = ""
Counter = 0
End If
End If
Next i
End With
End Sub
Related
I have a data like this :
A049
A050
A051
A053
A054
A055
A056
A062
A064
A065
A066
And I want the output like :
As you can see, I want the ranges which are in consecutive order
I am trying some thing like this:
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
For i = 2 To lastRow
r = wb.Sheets("Sheet1").Range("A" & i).Value
If wb.Sheets("Sheet1").Range("A" & i).Value = wb.Sheets("Sheet1").Range("A" & i+1).Value
Next i
End Sub
But not helping me
Am feeling charitable so have tried some code which should work. It assumes your starting values are in A1 down and puts results in C1 down.
Sub x()
Dim v1, v2(), i As Long, j As Long
v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim v2(1 To UBound(v1, 1), 1 To 2)
For i = LBound(v1, 1) To UBound(v1, 1)
j = j + 1
v2(j, 1) = v1(i, 1)
If i <> UBound(v1, 1) Then
Do While Val(Right(v1(i + 1, 1), 3)) = Val(Right(v1(i, 1), 3)) + 1
i = i + 1
If i = UBound(v1, 1) Then
v2(j, 2) = v1(i, 1)
Exit Do
End If
Loop
End If
If v1(i, 1) <> v2(j, 1) Then v2(j, 2) = v1(i, 1)
Next i
Range("C1").Resize(j, 2) = v2
End Sub
Try the below code
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
Dim lastNum, Binsert As Integer
Dim firstCell, lastCell, currentCell As String
Binsert = 1
lastNum = getNum(wb.Sheets("Sheet1").Range("A1").Value)
firstCell = wb.Sheets("Sheet1").Range("A1").Value
For i = 2 To lastRow
activeNum = getNum(wb.Sheets("Sheet1").Range("A" & i).Value)
currentCell = wb.Sheets("Sheet1").Range("A" & i).Value
If (activeNum - lastNum) = 1 Then
'nothing
Else
lastCell = wb.Sheets("Sheet1").Range("A" & (i - 1)).Value
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> lastCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = lastCell
End If
Binsert = Binsert + 1
firstCell = wb.Sheets("Sheet1").Range("A" & i).Value
End If
lastNum = activeNum
Next i
'last entry
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> currentCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = currentCell
End If
End Sub
Public Function getNum(ByVal num As String) As Integer
getNum = Val(Mid(num, 2))
End Function
Another solution. It loops backwards from last row to first row.
Option Explicit
Public Sub FindConsecutiveValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long 'find last row
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim lVal As String 'remember last value (stop value)
lVal = ws.Range("A" & lRow).Value
Const fRow As Long = 2 'define first data row
Dim i As Long
For i = lRow To fRow Step -1 'loop from last row to first row backwards
Dim iVal As Long
iVal = Val(Right(ws.Range("A" & i).Value, Len(ws.Range("A" & i).Value) - 1)) 'get value of row i without A so we can calculate
Dim bVal As Long
bVal = 0 'reset value
If i <> fRow Then 'if we are on the first row there is no value before
bVal = Val(Right(ws.Range("A" & i - 1).Value, Len(ws.Range("A" & i - 1).Value) - 1)) 'get value of row i-1 without A
End If
If iVal - 1 = bVal Then
ws.Rows(i).Delete 'delete current row
Else
If lVal <> ws.Range("A" & i).Value Then 'if start and stop value are not the same …
ws.Range("B" & i).Value = lVal 'write stop value in column B
End If
lVal = ws.Range("A" & i - 1).Value 'remember now stop value
End If
Next i
End Sub
How do i put multiple values from different cells (eg: values that lies below header x rel and y rel previously obtained by my program) and put them in the same cell which lies the same row as device d?(not manually select in excel or selectively using coding). What my current code does is to locate the x and y values of reliability fails then stored them in array(not sure is it correct or not) but after that how to concatenate them in the same cell shown in "After"?
Public Sub FindAndConvertforreliabilityfails()
Dim i As Integer
Dim j As Integer
Dim lastRow As Long
Dim myRng As Range
Dim mycell As Range
Dim MyColl As Collection
Dim myIterator As Variant
Set MyColl = New Collection
Dim xpos As integr, ypos As Integer
MyColl.Add "x rel"
MyColl.Add "y rel"
Dim LastCol As Integer
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To LastCol
For j = 1 To lastRow
For Each myIterator In MyColl
Do While Sheets(1).Cells(1, j).Value <> ""
If Sheets(1).Cells(1, i).Value = myIterator Then
xpos(j) = Sheets(1).Cells(Rows.Count, 6).End(xlUp).Offset(1, 0)
Else
ypos(j) = Sheets(1).Cells(Rows.Count, 7).End(xlUp).Offset(1, 0)
End If
Loop
Next
Next
' how to continue from here for the concatenate portion?
End Sub
Before
After
Currently
Try this. This will give you the expected output.
Private Sub Test()
Dim output As Variant
Dim outputrow As Integer
output = ""
outputrow = 0
For i = 2 To 5 'change 5 to lastrow of F&G Column.
If Cells(i, "B").Value = 0 Then
output = output & "(" & Cells(i, "F").Value & "," & Cells(i, "G").Value & "),"
Else
Cells(i, "E") = Left(output, Len(output) - 1)
output = "(" & Cells(i, "F").Value & "," & Cells(i, "G").Value & "),"
End If
Next i
Cells(i, "E") = Left(output, Len(output) - 1)
End Sub
I have written a piece of code that does reconciliation:
The first part checks between columns.
Works absolutely fine on upto 100k Rows, then simply freezes on anything bigger. Is the an optimal way to write this? Should I be using a scripting dictionary for the reconciliation too? Ive been off VBA for a while now and I am pretty rusty! Thanks for reading and helping.
Sub AutoRecon()
Worksheets("Main_Recon").Select
Dim i As Long, _
LRa As Long, _
LRb As Long, _
rowx As Long
LRa = Range("A" & Rows.Count).End(xlUp).Row
LRb = Range("G" & Rows.Count).End(xlUp).Row
rowx = 2
Application.ScreenUpdating = False
For i = 2 To LRa
If Range("A" & i).Errors.Item(xlNumberAsText).Value = True Then
Range("A" & i).Value = "N" & Range("A" & i).Value
rowx = rowx + 1
End If
Next i
rowx = 2
For i = 2 To LRb
If Range("G" & i).Errors.Item(xlNumberAsText).Value = True Then
Range("G" & i).Value = "N" & Range("G" & i).Value
rowx = rowx + 1
End If
Next i
rowx = 2
For i = 2 To LRa
If IsError(Application.Match(Range("A" & i).Value, Range("G2:G" & LRb), 0)) Then
Range("O" & rowx).Value = Range("A" & i).Value
rowx = rowx + 1
End If
Next i
rowx = 2
For i = 2 To LRb
If IsError(Application.Match(Range("G" & i).Value, Range("A2:A" & LRa), 0)) Then
Range("S" & rowx).Value = Range("G" & i).Value
rowx = rowx + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
This takes too long.
The issue is that you run the loop 4 times, but you can combine 2 loops.
You can gain some speed in the process using arrays to read/write. Every read/write action to a cell needs a lot of time. So the idea is to read all data cells into an array DataA at once (only 1 read action) then process the data in the array and then write it back to the cells at once (only 1 write action). So if you have 100 rows you save 99 read/write actions.
So you would end up with something like below. Note this is untested, so backup before running this.
Option Explicit
Public Sub AutoRecon()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Main_Recon")
Application.ScreenUpdating = False
'find last rows of columns
Dim LastRowA As Long
LastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim LastRowG As Long
LastRowG = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
'read data into array
Dim DataA() As Variant 'read data from column A into array
DataA = ws.Range("A1", "A" & LastRowA).Value
Dim DataG() As Variant 'read data from column G into array
DataG = ws.Range("G1", "G" & LastRowG).Value
Dim iRow As Long
For iRow = 2 To Application.Max(LastRowA, LastRowG) 'combine loop to the max of both columns
If iRow <= LastRowA Then 'run only until max of column A
If ws.Cells(iRow, "A").Errors.Item(xlNumberAsText).Value = True Then
DataA(iRow, 1) = "N" & DataA(iRow, 1)
End If
End If
If iRow <= LastRowG Then 'run only until max of column G
If ws.Cells(iRow, "G").Errors.Item(xlNumberAsText).Value = True Then
DataG(iRow, 1) = "N" & DataG(iRow, 1)
End If
End If
Next iRow
'write array back to sheet
ws.Range("A1", "A" & LastRowA).Value = DataA
ws.Range("G1", "G" & LastRowG).Value = DataG
'read data into array
Dim DataO() As Variant 'read data from column O into array (max size = column A)
DataO = ws.Range("O1", "O" & LastRowA).Value
Dim DataS() As Variant 'read data from column G into array (max size = column G)
DataS = ws.Range("S1", "S" & LastRowG).Value
Dim oRow As Long, sRow As Long
oRow = 2 'output row start
sRow = 2
For iRow = 2 To Application.Max(LastRowA, LastRowG) 'combine loop to the max of both columns
If iRow <= LastRowA Then
If IsError(Application.Match(DataA(iRow, 1), DataG, 0)) Then
DataO(oRow, 1) = DataA(iRow, 1)
oRow = oRow + 1
End If
End If
If iRow <= LastRowG Then
If IsError(Application.Match(DataG(iRow, 1), DataA, 0)) Then
DataS(sRow, 1) = DataG(iRow, 1)
sRow = sRow + 1
End If
End If
Next iRow
'write array back to sheet
ws.Range("O1", "O" & LastRowA).Value = DataO
ws.Range("S1", "S" & LastRowG).Value = DataS
Application.ScreenUpdating = True
End Sub
I am trying to eliminate line items that cancel each other out.
For example, below the two rows that add to zero would be deleted (i.e., 87.1 and -87.1).
-87.1
890
87.1
898989
The code that I am using mostly works but in cases where there are numerous lines with the same values it is deleting all of them instead of just one matching value per observation. For example, below, I would want it to cancel out two of the -87.1s and two of the 87.1s but one would be leftover because there is no number directly offsetting it.
-87.1
890
87.1
898989
87.1
-87.1
-87.1
Sub x()
Dim n As Long, rData As Range
Application.ScreenUpdating = False
n = Range("C" & Rows.Count).End(xlUp).Row
Range("AV2:AV" & n).Formula = "=IF(I2=0,0,COUNTIFS($C$2:$C$" & n & ",C2,$I$2:$I$" & n & ",-I2))"
With ActiveSheet
.AutoFilterMode = False
.Rows(1).AutoFilter field:=48, Criteria1:=">0"
With .AutoFilter.Range
On Error Resume Next
Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rData Is Nothing Then
rData.EntireRow.Delete shift:=xlUp
End If
End With
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
I think you need something like this:
Sub DeleteOppositeNumbers()
Dim Fnd As Range, r As Long
'By: Abdallah Ali El-Yaddak
Application.ScreenUpdating = False
'Loop through the column bottom to top.
For r = Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
If Cells(r, 3).Value > 0 Then 'If the value is positive
'Sreach for it's opposite
Set Fnd = Columns(3).Find(-Cells(r, 3).Value, LookAt:=xlWhole)
'If found, delete both.
If Not Fnd Is Nothing Then Rows(r).Delete: Fnd.EntireRow.Delete
End If
Next
'Just to restore normal behaviour of sreach
Set Fnd = Columns(3).Find(Cells(3, 2).Value, LookAt:=xlPart)
Application.ScreenUpdating = True
End Sub
Perhaps Something Simpler:
Sub x()
Dim ar() As Variant
Dim i As Integer
Dim j As Integer
Dim n As Integer
n = Range("C" & Rows.Count).End(xlUp).Row
Range("AV2:AV" & n).Formula = "=IF(I2=0,0,COUNTIFS($C$2:$C$" & n & ",C2,$I$2:$I$" & n & ",-I2))"
ar = ActiveSheet.Range("AV2:AV" & last).Value
For i = LBound(ar) To UBound(ar)
For j = LBound(ar) To UBound(ar)
If i <> j Then
If ar(i, 1) = ar(j, 1) Then
ar(i, 1) = ""
ar(j, 1) = ""
End If
End If
Next
Next
For i = LBound(ar) To UBound(ar)
ActiveSheet.Range("AV" & i + 1).Value = ar(i, 1)
Next
ActiveSheet.Range("AV2:AV" & last).SpecialCells(xlCellTypeBlanks).Delete xlUp
End Sub
I have tried and tested this one.
You could try:
Option Explicit
Sub test()
Dim arr As Variant
Dim LastRow As Long, i As Long, j As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = Range("A1:A" & LastRow)
For i = UBound(arr) To LBound(arr) Step -1
For j = UBound(arr) - 1 To LBound(arr) Step -1
If arr(i, 1) + arr(j, 1) = 0 Then
.Rows(i).EntireRow.Delete
.Rows(j).EntireRow.Delete
Exit For
End If
Next j
Next i
End With
End Sub
I have a table which contains merged cells both column and rows as shown in attached picture. I want to unmerge "Only" rows while leaving columns merged. Consider the following snippet of table. In the image attached "Contract
For y = 1 To lRow
p = 1
c = y
d = 1
z = lRow + y
t = Cells(y, 1).Value
For x = 1 To t
Cells(z, p).Value = Cells(c, d).Value
Cells(c, d).Select
' Debug.Print
Selection.End(xlToRight).Select
c = ActiveCell.Row
d = ActiveCell.Column
p = p + 1
Next
Next
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
With c.MergeArea.Rows
.UnMerge
' .Formula = c.Formula
End With
'
'startcolumn = ActiveCell.Column
'endcolumn = Selection.Columns.Count + startcolumn - 1
'startrow = ActiveCell.Row
'endrow = Selection.Rows.Count + startrow - 1
End If
Next
End Sub
Based on your snapshot of requirements , I have wrote a very simple code which shall appear to be crude but I have kept it this way so that you can adjust its various elements as per your actual data. Sample data taken by me and results obtained are shown in the snapshot pasted below, which is followed by code.
Sub Merge_unmerge()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim LastRow As Long
Dim LastCol As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
With ws
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Set rng = ws.Range("A1:D" & LastRow)
For Each cell In rng
cell.UnMerge
Next cell
For i = 2 To LastRow
If Range("A" & i) = "" Then
Range("A" & i).Value = Range("A" & i - 1).Value
End If
Next i
For i = 2 To LastRow
If Range("D" & i) = "" Then
Range("D" & i).Value = Range("D" & i - 1).Value
End If
Next i
For i = 1 To LastRow Step 2
Range("B" & i & ":C" & i).Merge
Range("B" & i & ":C" & i).HorizontalAlignment = xlCenter
Next i
End Sub
Never mind. I solved for the issue at hand. Posting if it helps others.
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
startcolumn = c.Column
endcolumn = c.MergeArea.Columns.Count + startcolumn - 1
startrow = c.Row
endrow = c.MergeArea.Rows.Count + startrow - 1
With c.MergeArea.Rows
.UnMerge
.Formula = c.Formula
End With
For J = startrow To endrow
Application.DisplayAlerts = False
Range(Cells(J, startcolumn), Cells(J, endcolumn)).Merge
Application.DisplayAlerts = True
Next
End If
Next
End Sub