I have a code that works well for inserting multiple rows by specifying values for 2 columns. I am not sure how to add in the code to highlight the new inserted rows in some color. Here is my code -
Sub Multiplerows()
Dim rng As Integer, k As Integer
Dim attrib As String
Dim BMI As String
Dim rRange As Range
Dim salesID As Long, salesMkt As String
Set rRange = Selection
On Error Resume Next
rng = InputBox("Enter number:.")
item = InputBox("Enter name of the Item:.")
subject = InputBox("Enter name of the sub item:.")
'If rng = 0 Then Exit Sub
For k = 1 To rng
Rows(rRange.Row).Insert Shift:=xlDown
Next k
For k = rng To 1 Step -1
Cells(rRange.Row - k, 10) = item
Cells(rRange.Row - k, 8) = subject
Next k
End Sub
Depends on what exactly you want to do (e.g. highlight based on row values), but in your lower loop you could do something like
For k = rng To 1 Step -1
Cells(rRange.Row - k, 10) = item
Cells(rRange.Row - k, 8) = subject
ActiveSheet.Rows(rRange.Row - k).Interior.Color = RGB(255, 0, 0)
Next k
This would highlight the new row as bright red. Change the RGB values to whatever you like.
Related
I have the following macro that I got from someone, and trying to modify it to suit my purpose.
I'm trying to alter this macro to find and highlight cells that have duplicate values within each cell,
for example, it should highlight B62 and B63 (green),
and color font red the duplicate values (i.e. B_HWY_1010 in B62, and B_HWY_1015 in B63)
Sub Dupes()
Dim d As Object
Dim a As Variant, itm As Variant
Dim i As Long, k As Long
Dim rng As Range
Dim bColoured As Boolean
Set d = CreateObject("Scripting.Dictionary")
Set rng = Range("B1", Range("B" & Rows.Count).End(xlUp))
a = rng.Value
For i = 1 To UBound(a)
For Each itm In Split(a(i, 1), ",")
d(itm) = d(itm) + 1
Next itm
Next i
Application.ScreenUpdating = False
For i = 1 To UBound(a)
k = 1
bColoured = False
For Each itm In Split(a(i, 1), ",")
If d(itm) > 1 Then
If Not bColoured Then
rng.Cells(i).Interior.Color = vbGreen
bColoured = True
End If
rng.Cells(i).Characters(k, Len(itm)).Font.Color = RGB(244, 78, 189)
End If
k = k + Len(itm) + 1
Next itm
Next i
Application.ScreenUpdating = True
End Sub
Any help or advise is appreciated.
The following will do that
Option Explicit
Public Sub Example()
Dim Cell As Range
For Each Cell In Range("A1:A10")
HighlightRepetitions Cell, ", "
Next Cell
End Sub
Private Sub HighlightRepetitions(ByVal Cell As Range, ByVal Delimiter As String)
If Cell.HasFormula Or Cell.HasArray Then Exit Sub ' don't run on formulas
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim Data() As String
Data = Split(Cell.Value, Delimiter) ' split data in the cell by Delimiter
Dim StrLen As Long ' length of the string that was already processed
Dim i As Long
For i = LBound(Data) To UBound(Data) ' loop through all data items
Dim DataLen As Long
DataLen = Len(Data(i)) 'get length of current item
If Dict.Exists(Data(i)) Then
' item is a repetition: color it
Cell.Characters(StrLen + 1, DataLen).Font.Color = vbRed
Cell.Interior.Color = vbGreen
Else
' item is no repetition: add it to the dictionary
Dict.Add Data(i), Data(i)
End If
StrLen = StrLen + DataLen + Len(Delimiter) ' calculate the length of the processed string and add length of the delimiter
Next i
End Sub
The following items would be colored:
You can turn ScreenUpdating off before looping in Sub Example() and turn on after the loop to stop it from flickering. Note this will not run on formuas, as parts of formula results cannot be colored. This can be prevented by using If Cell.HasFormula Or Cell.HasArray Then Exit Sub as first line.
Please, try the next code, too:
Sub findComaDelDuplicates()
Dim sh As Worksheet, arr, itm, arrInt, i As Long, rngS As Range, pos As Long
Dim arrDif As Long, j As Long, startPos As Long, arrPos, k As Long, mtch
Set sh = ActiveSheet
With sh.Range("B1", Range("B" & sh.rows.count).End(xlUp))
arr = .value 'put the range value in an array to make the iteration faster
.ClearFormats 'clear previous format
.Font.Color = vbBlack 'make the font color black
End With
For i = 1 To UBound(arr) 'iterate between the array elements:
arrInt = Split(arr(i, 1), ",") 'split the content by comma delimiter
ReDim arrPos(UBound(arrInt)) 'redim the array keeping elements already formatted
For Each itm In arrInt 'iterate between the comma separated elements
arrDif = UBound(arrInt) - 1 - UBound(Filter(arrInt, itm, False)) 'find how many times an element exists
If arrDif > 0 Then 'if more then an occurrence:
If rngS Is Nothing Then 'if range to be colored (at once) does not exist:
Set rngS = sh.Range("B" & i) 'it is crated
Else
Set rngS = Union(rngS, sh.Range("B" & i)) 'a union is made from the previous range and the new one
End If
mtch = Application.match(itm, arrPos, 0) 'check if the itm was already processed:
If IsError(mtch) Then 'if itm was not processed:
For j = 1 To arrDif + 1 'iterate for number of occurrences times
If j = 1 Then startPos = 1 Else: startPos = pos + 1 'first time, inStr starts from 1, then after the first occurrence
pos = InStr(startPos, sh.Range("B" & i).value, itm) 'find first character position for the itm to be colored
sh.Range("B" & i).Characters(pos, Len(itm)).Font.Color = vbRed 'color it
Next j
arrPos(k) = itm 'add the processed itm in the array
End If
End If
Next
Erase arrInt 'clear the array for the next cell value
Next i
If Not rngS Is Nothing Then rngS.Interior.Color = vbGreen 'color the interior cells of the built range
End Sub
Attention: The above code puts the range in an array to iterate much faster. But, if the range does not start form the first row, the cells to be processed must be obtained by adding to i the rows up to the first of the range. The code can be adapted to make this correlation, but I am too lazy to do it now...:)
Here is my current output that my VBscript is generating.
ID DESCRIPTION 1 RECURSIVE_ANALYSIS
CM-1 xxxxxxxxxxxx Issue A
Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B
Sub issue a
Sub issue b
This is following VBA code which i have designed for getting the output
Sub CellSplitter1()
Dim Temp As Variant
Dim CText As String
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim iColumn As Integer
Dim lNumCols As Long
Dim lNumRows As Long
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim iTargetRow As Integer
iColumn = 3
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
iTargetRow = 0
With wksSource
lNumCols = .Range("IV1").End(xlToLeft).Column
lNumRows = .Range("A65536").End(xlUp).Row
For J = 1 To lNumRows
CText = .Cells(J, iColumn).Value
Temp = Split(CText, Chr(10))
For K = 0 To UBound(Temp)
iTargetRow = iTargetRow + 1
For L = 1 To lNumCols
If L <> iColumn Then
wksNew.Cells(iTargetRow, L) _
= .Cells(J, L)
Else
wksNew.Cells(iTargetRow, L) _
= Temp(K)
End If
Next L
Next K
Next J
End With
End Sub
Here is my expected output
ID DESCRIPTION 1 RECURSIVE_ANALYSIS Issues
CM-1 xxxxxxxxxxxx Issue A Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B Sub issue a
Sub issue b
So, can someone help me to figure out to get the expected output.
Any help will be much appreciated.
Thank you
it seems you didn't show the whole story, so here's a guessing:
after your code place the following
With wksNew' reference 'wksNew' sheet
With .Range(.Cells(1, iColumn), .Cells(iTargetRow, iColumn)) ' reference its 'iColumn' column range from row 1 down to its last not empty one
.Insert 'insert a new column before referenced range. now the currently referenced range is one column right shifted (i.e. its in the 4th column of referenced sheet)
.Offset(, -1).Value = .Value ' copy values from referenced range one column to the left (i.e. in the newly created column)
.Offset(, -1).Replace "Sub issue*", "", lookat:=xlWhole 'clear the newly created range cells containing "Sub issue..." (hence, there remains cells with "Issue .." only)
.Replace "Issue *", "", lookat:=xlWhole 'clear the currently referenced range (i.e the one in 4th column) cells containing "Issue..." (hence, there remains cells with "Sub issue .." only)
End With
.Columns.AutoFit 'adjust your columns width
End With
Using Variant array is more simple.
Sub test()
Dim r As Long, c As Integer
Dim j As Integer
Dim k As Integer
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim vDB, vSplit, vR()
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
With wksSource
c = .Range("IV1").End(xlToLeft).Column
r = .Range("A65536").End(xlUp).Row
vDB = .Range("a1", .Cells(r, c))
For i = 1 To r
vSplit = Split(vDB(i, c), Chr(10))
For k = 1 To UBound(vSplit)
n = n + 1
ReDim Preserve vR(1 To c + 1, 1 To n)
If k = 1 Then
For j = 1 To c - 1
vR(j, n) = vDB(i, j)
Next j
vR(c, n) = vSplit(k - 1)
vR(c + 1, n) = vSplit(k)
Else
vR(c + 1, n) = vSplit(k)
End If
Next k
Next i
End With
Range("a1").Resize(1, c + 1) = Array("ID", "DESCRIPTION 1", "RECURSIVE_ANALYSIS", "Issues")
Range("a2").Resize(n, c + 1) = WorksheetFunction.Transpose(vR)
End Sub
Here is the sample of my current output which the VBscript code is generating.
[https://i.stack.imgur.com/kMpih.png] [1]:
Here is the sample of my expected output
[[1]: https://i.stack.imgur.com/StBqx.png]
Please let me know your suggestions.
Thank you
i want to compare the values in the array taken from a certain column with values of another column
but i am getting an error "subscript is out of range"
is there a better way of doing this?
Dim start As Integer
Dim SrchRngzc As Range, cel As Range, SrchRngyx As Range, cel2 As Range
Set SrchRngzc = Range("zc16:zc500")
Set SrchRngyx = Range("yx16:yx100")
Dim x As Integer, a As Integer, b As Integer, c As Integer
Dim y As Integer
Dim n As Integer
Dim arr(1 To 85) As String
Dim num(1 To 85) As Integer
y = 1
c = 1
'highlight cells that matches
For Each cel In SrchRngyx
arr(y) = cel.Value
y = y + 1
Next cel
For Each cel2 In SrchRngzc
n = 1
For c = 1 To y
If arr(n) = cel2.Value Then ' error occurs here
cel2.Interior.ColorIndex = 4
n=n+1
Exit For
End If
Next c
Next cel2
The code below has 1 For to loop through all cells in column "ZC", and then per cell checks if there is a match somewhere in column "YC", by using the Application.Match.
Code
Option Explicit
Sub MatchColumns()
Dim SrchRngzc As Range, Cel As Range, SrchRngyx As Range
Set SrchRngzc = Range("ZC16:ZC500")
Set SrchRngyx = Range("YX16:YX100")
' loop thorugh cells in column "ZC"
For Each Cel In SrchRngzc
' check if courrent value in column "ZC" has a match in column "YX"
If Not IsError(Application.Match(Cel.Value, SrchRngyx, 0)) Then
Cel.Interior.ColorIndex = 4
End If
Next Cel
End Sub
You have set y to 86 at the end of your first For . . . Next loop. When you try to access arr(86) you get your error. Instead try
y=0
For Each cel in SrchRngyx
y = y+ 1
arr(y) = cel.value
Next
This still starts at 1 but ends at 85.
What I am trying to do is develop a model that takes a cell that is greater than 1 then to take the sum of the area to the first row using a cone shape, so for example cell D4, sum the area C3:C5 + B2:B6 + A1:A7.
At the moment I have this but it obviously is not working.
Dim I As Double
Dim J As Double
Dim Size As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
'Dim Range As Integer
Dim PV1 As Integer
'MCArray = Worksheets("Data")
I = WorksheetFunction.CountA(Worksheets("Data").Rows(1))
J = WorksheetFunction.CountA(Worksheets("Data").Columns(1))
'Loop to Move down the rows
For x = 1 To J
'Loop to move acoss the columns
For y = 1 To I
'IfElse to determine if cell value is greater or equal to zero
If Cells(J, I).Value >= 0 Then
'Loop to sum the cells above
For z = 1 To J
PV1 = (ActiveCell.Value) + Worksheet.Sum(Range([J - z], [I-z:I+z]))
'IfElse to determine if final sum is greater than zero
If PV1 > 0 Then
Worksheets("MC").Range("B4").Value = PV1
Range([J - z], [I-z:I+z]).Interior.ColourIndex = 1
End If
Next z
End If
Next y
Next x
Here is a function you can use either as a UDF or from another routine. Just pass it the single cell you want to start from (D4 in your example) and this function will calculate the sum of the cone as you described.
Public Function SUMCONE(r As Range) As Double
Application.Volatile
SUMCONE = Application.Sum(r, r(-0, -0).Resize(, 3), r(-1, -1).Resize(, 5), r(-2, -2).Resize(, 7))
End Function
Here is an example of how to use the above function from your VBA routine:
Public Sub Demo()
Dim j&
For j = 5 To 10
If Cells(5, j) > 0 Then
Debug.Print SUMCONE(Cells(5, j))
End If
Next
End Sub
UPDATE
Based on your feedback I have updated the function and the demo routine to form an upward cone summation from the initial cell.
UPDATE #2
The above is for a fixed-size cone, extending upwards, that can be initiated from any cell in the worksheet.
But if you would prefer for the cone to always extend all the way up to row 1 regardless of which cell it originates in, then the following is what you are after:
Public Sub Demo()
Dim i&, j&
For j = 1 To Application.CountA(Worksheets("Data").Rows(1))
For i = 1 To Application.CountA(Worksheets("Data").Columns(1))
If Cells(i, j) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
UPDATE #3
As I suspected there was a problem if the cone was initiated too close to the left edge of the worksheet. I've added code to handle that now. Also your method for accessing the large matrix (which I had used in the Demo routine) did not work properly. I fixed that as well:
Public Sub Demo()
Dim i&, j&
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Val(Cells(i, j)) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then Exit For
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
I am looking to find out how I can remove ALL duplicate rows (when duplicates exist in the first column) using a VBA macro.
Currently Excel macros delete all duplicate instances EXCEPT for the first instance, which is totally not what I want. I want absolute removal.
A bit shorter solution done for quick morning training:
Sub quicker_Option()
Dim toDel(), i As Long
Dim RNG As Range, Cell As Long
Set RNG = Range("a1:a19") 'set your range here
For Cell = 1 To RNG.Cells.Count
If Application.CountIf(RNG, RNG(Cell)) > 1 Then
ReDim Preserve toDel(i)
toDel(i) = RNG(Cell).Address
i = i + 1
End If
Next
For i = UBound(toDel) To LBound(toDel) Step -1
Range(toDel(i)).EntireRow.Delete
Next i
End Sub
Store the first instance's cell for later deleting.
Then go deleting duplicates until the end.
Dim F as integer, S as integer 'indices for First and Second cells to be compared
Dim Deleted as boolean 'indicates if second line was deleted
Dim First as Range, Second as Range 'First and second cells to be compared
Dim Start as string 'Indicates the position of the first cell's start
Start = "A1" 'can be as you like
Set First = Sheet1.Range(Start) 'Sets the start cell
F = 0 '
Do While First.Value <> "" 'loop while sheet contains data in the column
S = F + 1 'second cell is at least 1 cell below first cell
Deleted = false 'no second cell was deleted yet
Set Second = First.Offset(S,0) 'second cell is an offset of the first cell
Do While Second.Value <> "" 'loop while second cell is in sheet's range with data
if Second.Value = First.Value then 'if values are duplicade
Second.EntreRow.Delete 'delete second cell
Deleted = true 'stores deleted information
else 'if not, second cell index goes next
S = S + 1;
end if
Set Second = First.Offset(S, 0) 'sets second cell again (if deleted, same position, if not deleted, next position
Loop
if Deleted then 'if deleted, should delete first cell as well
First.EntireRow.Delete
else
F = F + 1 'if no duplicates found, first cell goes next
end if
Set First = Sheet1.Range(Start).Offset(F,0) 'sets first cell again (if deleted, same position, if not, next)
Loop
I am using this code to create an Auto reconciliation of general ledger control accounts where if any cell with equal value but opposite sign is cut to sheet 2; hence left with only reconciliation item.
the code:
sub autoRecs()
dim i as long
Application.ScreenUpdating = False
Application.StatusBar = True
Dim i As Long
Cells(5, 6).Select
Dim x As Long
Dim y As Long
x = ActiveCell.Row
y = x + 1
Do Until Cells(x, 6) = 0
Do Until Cells(y, 6) = 0
Application.StatusBar = "Hey Relax! You can rely on me......"
If Cells(x, 6) = Cells(y, 6) * -1 Then
Cells(x, 6).EntireRow.Cut (Worksheets(2).Cells(x, 6).EntireRow)
Cells(y, 6).EntireRow.Cut (Worksheets(2).Cells(y, 6).EntireRow)
Cells(x, 6).Value = "=today()"
Cells(y, 6).Value = "=today()"
Else
y = y + 1
End If
Loop
x = x + 1
y = x + 1
Loop
Application.StatusBar = False
End Sub
Sub deleteBlankCells()`this is to delete unnecessary cells after run the above macro`
Range(Cells(5, 1), Cells(Rows.Count, 1).End(xlUp)).Select
For i = Selection.Rows.Count To 1 Step -1
Application.StatusBar = "OOH! I'm cleaning all the blanks for you....."
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
Application.StatusBar = False
End Sub
I like to work with arrays within VBA, so here is an example.
Assume the data represents the currentregion around A1, but that is easily changed
Read the source data into an array
Check each item in column one to ensure it is unique (countif of that item = 1)
If unique, add the corresponding row number to a Collection
Use the size of th collection and the number of columns to Dim a results array.
Cycle through the collection, writing the corresponding rows to a results array.
Write the results array to the worksheet.
As written, the results are placed to the right of the source data, but could also replace it, or be placed on a different sheet.
Option Explicit
Sub RemoveDuplicatedRows()
Dim vSrc As Variant, vRes() As Variant
Dim rSrc As Range, rRes As Range
Dim colUniqueRows As Collection
Dim I As Long, J As Long
'assume data starts in A1 and represented by currentregion
Set rSrc = Range("a1").CurrentRegion
vSrc = rSrc
Set rRes = rSrc.Offset(0, UBound(vSrc, 2) + 2)
'get collection of non-duplicated rows
Set colUniqueRows = New Collection
For I = 1 To UBound(vSrc)
If WorksheetFunction.CountIf(rSrc.Columns(1), vSrc(I, 1)) = 1 Then _
colUniqueRows.Add I
Next I
'Make up results array
ReDim vRes(1 To colUniqueRows.Count, 1 To UBound(vSrc, 2))
For I = 1 To UBound(vRes, 1)
For J = 1 To UBound(vSrc, 2)
vRes(I, J) = vSrc(colUniqueRows(I), J)
Next J
Next I
rRes.EntireColumn.Clear
rRes.Resize(UBound(vRes)) = vRes
End Sub