I have a macro that adds 1 to a cell in Column 53 (Column BA) if the row below it has a cell that contains a bracketed number "(2)" and another cell that contains the word "Adult".
It goes like this:
Sub BUBFindAdults2()
lastRow = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
For x = 3 To lastRow
If InStr(1, Sheets("Sheet1").Cells(x, 3), "(2)") <> 0 _
And InStr(1, Sheets("Sheet1").Cells(x, 31), "Adult") <> 0 Then
Sheets("Sheet1").Cells(x - 1, 53).Value = _
Sheets("Sheet1").Cells(x - 1, 53).Value + 1
End If
Next x
End Sub
However, I also need it to add 1 to the same cell if two rows below contains "(3)" and "Adult". And if three rows below contains "(4)" and "Adult". And so on. You see the pattern!
So far, I've got around this by just repeating the same code as follows:
Sub BUBFindAdults2()
lastRow = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
For x = 3 To lastRow
If InStr(1, Sheets("Sheet1").Cells(x, 3), "(2)") <> 0 _
And InStr(1, Sheets("Sheet1").Cells(x, 31), "Adult") <> 0 Then
Sheets("Sheet1").Cells(x - 1, 53).Value = _
Sheets("Sheet1").Cells(x - 1, 53).Value + 1
End If
If InStr(1, Sheets("Sheet1").Cells(x, 3), "(3)") <> 0 _
And InStr(1, Sheets("Sheet1").Cells(x, 31), "Adult") <> 0 Then
Sheets("Sheet1").Cells(x - 2, 53).Value = _
Sheets("Sheet1").Cells(x - 2, 53).Value + 1
End If
If InStr(1, Sheets("Sheet1").Cells(x, 3), "(4)") <> 0 _
And InStr(1, Sheets("Sheet1").Cells(x, 31), "Adult") <> 0 Then
Sheets("Sheet1").Cells(x - 3, 53).Value = _
Sheets("Sheet1").Cells(x - 3, 53).Value + 1
End If
Next x
End Sub
You can probably tell that this starts to get a bit silly when I'm dealing with 10+ repetitions! I know one of the main rules of writing VBA is avoiding repeated code. I've looked at a few other examples of people looping their code but I haven't had any luck applying the methods to my own.
Any help would be much appreciated.
You can first use a filter on the column 31 to have only the rows where "Adult" appears. After that it becomes somehow simpler, and surely faster.
Sub BUBFindAdults2()
With Sheets("Sheet1").UsedRange
.AutoFilter 31, "*Adult*"
Dim r As Range, i As Integer
For Each r In .SpecialCells(xlCellTypeVisible).EntireRow
For i = 2 To 4
If r.Cells(3) Like "*(" & i & ")*" Then
With r.Offset(1 - i).Cells(53)
.Value = .Value + 1
End With
End If
Next
Next
.Parent.AutoFilterMode = False
End With
End Sub
I can't get your code to run, but this can easily be achieved using a nested for loop. See the below code, which will execute 10 repetitions, based on the code you provided in the question:
Sub BUBFindAdults2()
lastRow = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
For x = 3 To lastRow
If InStr(1, Sheets("Sheet1").Cells(x, 31), "Adult") <> 0 Then
For i = 1 To 10
If InStr(1, Sheets("Sheet1").Cells(x, 3), "(" & (i+1) & ")") <> 0 Then
Sheets("Sheet1").Cells(x - i, 53).Value = _
Sheets("Sheet1").Cells(x - i, 53).Value + 1
End If
Next i
End If
Next x
End Sub
Related
Source code:
Dim TH As Double
Lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
'starting point
sRow = 2
'Loop in all cells
For i = sRow To Lr
'check if cell value are not same
If Cells(i, 1).Value <> Cells(i + 1, 1) Then
'if not same then merge all the above cells
Range("I" & sRow, "I" & i).Resize(, 7).Select
TH = Application.WorksheetFunction.Sum(Selection)
**If TH <> 40 Then**
Range("A" & sRow, "A" & i).Interior.Color = RGB(255, 0, 0)
End If
In this Code:
If TH <> 40 Then condition not working when ever the TH is Calculated on Decimal Numbers.
Such as 3.60,0.80,4.60 Sum is coming as 40 when use SUM Function but If Condition is not getting fulfilled.
Please Help
I have tried this, putting decimals all over and it works:
Sub TestMe()
Dim lr As Long
Dim TH As Double
Dim i As Long
lr = 10
For i = 1 To lr
If Cells(i, 1).Value <> Cells(i + 1, 1) Then
Range("I" & 6, "I" & i).Resize(, 7).Select
TH = Application.WorksheetFunction.Sum(Selection)
If TH <> 40 Then
Range("A" & 6, "A" & i).Interior.Color = RGB(255, 0, 0)
End If
End If
Next
End Sub
Thus, probably the problem is the way you put the decimals. In some systems (German or French), the decimal separator is ,, while in English systems it is a point - .. Thus, you might be using the wrong one.
I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?
The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.
My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.
Sub test()
Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wks = Sheets("data")
wks.Activate
lEnd = ActiveSheet.UsedRange.Rows.Count
For l = 3 To lEnd
If Not IsEmpty(Cells(l, 1)) Then
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
Else: Cells(l, 1).EntireRow.Delete
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
End If
Next l
End Sub
and the 2nd code I tried
Sub transformdata()
'
Dim temp As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A3").Select
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, 3))
temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
ActiveCell.Offset(, 3).Value = temp
ActiveCell.Offset(1, 3).EntireRow.Delete
Loop
ActiveCell.Offset(1, 0).EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This
Here is a basic example.
Let's say your worksheet looks like this
If you run this code
Sub test()
Dim wks As Worksheet
Dim lRow As Long, i As Long
Dim temp As String
Application.ScreenUpdating = False
Set wks = Sheets("data")
With wks
'~~> Find Last Row
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
If temp = "" Then
temp = .Range("C" & i).Value
Else
temp = .Range("C" & i).Value & "," & temp
End If
Else
.Range("D" & i + 1).Value = temp
temp = ""
End If
Next i
End With
End Sub
You will get this output
Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.
The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.
Sub TransformData2()
Const COLUMNCOUNT = 4
Dim SourceData, NewData
Dim count As Long, x1 As Long, x2 As Long, y As Long
SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))
For x1 = 1 To UBound(SourceData, 1)
count = count + 1
If count = 1 Then
ReDim NewData(1 To 4, 1 To count)
Else
ReDim Preserve NewData(1 To 4, 1 To count)
End If
For y = 1 To UBound(SourceData, 2)
NewData(y, count) = SourceData(x1, y)
Next
x2 = x1 + 1
Do
NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
x2 = x2 + 1
If x2 > UBound(SourceData, 1) Then Exit Do
Loop Until IsEmpty(SourceData(x2, 4))
x1 = x2
Next
ThisWorkbook.Worksheets.Add
Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub
I am doing automation on matching Data form row Data1 to Data 2,
I was done by looping statement but the problem is take much time, when number of row increase
For that reason i planed do by vlookup, In vlookup only return first occurrence cell but i need to find all match cell and highlighted matched row ,which i show in figure.
Working with cells directly reduces the code performance. Try to set Data1 and Data2 to arrays and work with arrays.
Something like this:
With ActiveSheet
arr = .Range(.[A2], .Cells(.Rows.Count, "A").End(xlUp)).Value
arr2 = .Range(.[D2], .Cells(.Rows.Count, "D").End(xlUp)).Value
For i& = 1 To UBound(arr)
For j& = 1 To UBound(arr2)
If arr(i, 1) = arr2(j) Then
...
End If
Next j
Next i
End With
Hope you are looking for this
Sub testvlookup()
Dim lastrow, lastrowdata, incre, i, j As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
lastrowdata = Range("D" & Rows.Count).End(xlUp).Row
incre = 6
For i = 2 To lastrow
For j = 2 To lastrowdata
If Range("A" & i).Value = Range("D" & j).Value Then
Range("D" & j, "G" & j).Interior.ColorIndex = incre
End If
Next j
incre = incre + 1
Next i
End Sub
I don't see the point why it should be to slow for many rows, it would be good to have more informations about that.
I would do it like the others, takes ~1 sec with 100000 comparisons.
Dim i As Integer
Dim b As Integer
i = 1
While i < 20000
Range("A1:A5").Copy Range(Cells(i, 4), Cells(i + 5, 4))
i = i + 5
Wend
MsgBox ("hi")
i = 1
While i < 7
b = 3
While b < 20000
If Cells(i, 1).Value = Cells(b, 4).Value Then
Cells(b, 4).Interior.ColorIndex = i
End If
b = b + 1
Wend
i = i + 1
Wend
End Sub
I created a macro in Excel to mergue duplicated rows:
The idea is that if 2 rows or more have the same A B C columns, I mergue their D columns removing ABC duplicates.
I need to do this, but checking more colums.
My macro looks like this:
processingRow = 2
Do Until Cells(processingRow, 1).Value = ""
i = processingRow + 1
Do Until Cells(i, 1).Value = ""
If Cells(processingRow, 8) = Cells(i, 8) And _
Cells(processingRow, 12) = Cells(i, 12) And _
Cells(processingRow, 7) = Cells(i, 7) And _
Cells(processingRow, 6) = Cells(i, 6) And _
Cells(processingRow, 5) = Cells(i, 5) And _
Cells(processingRow, 4) = Cells(i, 4) And _
Cells(processingRow, 3) = Cells(i, 3) And _
Cells(processingRow, 2) = Cells(i, 2) And _
Cells(processingRow, 1) = Cells(i, 1) Then
If Cells(i, 14) <> "" Then
Cells(processingRow, 14) = Cells(processingRow, 14) & "," & Cells(i, 14)
End If
Rows(i).Delete
End If
i = i + 1
Loop
processingRow = processingRow + 1
Loop
When running the macro with 500 rows, it takes a while, but its still reasonable. But I need to run this macro in a excel with more than 2500 rows, and it takes so much time that its not practical anymore.
This is my first macro in excel using VBA, so I was wondering if there is a faster way to process rows/cells, since accessing them individually seems extremelly slow.
Any ideas?
EDITED: I missed that you weren't checking every column to determine what was a duplicate. This should be closer now:
Sub Tester()
Dim rngCheck As Range, rw As Range
Dim dict As Object, k As String, rwDup As Range
Dim rngDel As Range, tmp
Set dict = CreateObject("scripting.dictionary")
With ActiveSheet
Set rngCheck = .Range(.Cells(2, 1), _
.Cells(Rows.Count, 1).End(xlUp)).Resize(, 14)
End With
For Each rw In rngCheck.Rows
k = RowKey(rw)
If dict.exists(k) Then
Set rwDup = dict(k)
tmp = rw.Cells(14).Value
If Len(tmp) > 0 Then
rwDup.Cells(14).Value = rwDup.Cells(14).Value & "," & tmp
End If
If rngDel Is Nothing Then
Set rngDel = rw
Else
Set rngDel = Application.Union(rngDel, rw)
End If
Else
dict.Add k, rw
End If
Next rw
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
'create a "key" for the row by joining all columns to be checked
Function RowKey(rw As Range) As String
Dim arr, x As Long, sep As String, rv As String
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 12)
For x = LBound(arr) To UBound(arr)
rv = rv & sep & rw.Cells(arr(x)).Value
sep = Chr(0)
Next x
RowKey = rv
End Function
I am using the following VBA code to change the color of the rows in my spreadsheet every time the value in Column A changes (So that all entries with the same value in column A will be grouped by color. The spreadsheet is sorted by column A already so the items are already grouped, I just needed them colored).
Anyway, when I run this macro the rows are colored red & green (which are very bright and overwhelming colors for this purpose). I need something more subtle..
How do I change this? Or can I specify in my VBA code for it to use certain colors by rgb or color index? {I am using Excel 2007}
Sub colorize()
Dim r As Long, val As Long, c As Long
r = 1
val = ActiveSheet.Cells(r, 1).Value
c = 4
For r = 1 To ActiveSheet.Rows.Count
If IsEmpty(ActiveSheet.Cells(r, 1).Value) Then
Exit For
End If
If ActiveSheet.Cells(r, 1).Value <> val Then
If c = 3 Then
c = 4
Else
c = 3
End If
End If
ActiveSheet.Rows(r).Select
With Selection.Interior
.ColorIndex = c
.Pattern = xlSolid
End With
val = ActiveSheet.Cells(r, 1).Value
Next
End Sub
Run this program (credits here)
Sub colors56()
'57 colors, 0 to 56
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim i As Long
Dim str0 As String, str As String
For i = 0 To 56
Cells(i + 1, 1).Interior.ColorIndex = i
Cells(i + 1, 1).Value = "[Color " & i & "]"
Cells(i + 1, 2).Font.ColorIndex = i
Cells(i + 1, 2).Value = "[Color " & i & "]"
str0 = Right("000000" & Hex(Cells(i + 1, 1).Interior.Color), 6)
'Excel shows nibbles in reverse order so make it as RGB
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
'generating 2 columns in the HTML table
Cells(i + 1, 3) = "#" & str & "#" & str & ""
Cells(i + 1, 4).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"
Cells(i + 1, 5).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"
Cells(i + 1, 6).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"
Cells(i + 1, 7) = "[Color " & i & ")"
Next i
done:
Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic
Application.ScreenUpdating = True
End Sub
Output sample:
You can customize the colors palette by code, I think the page here will answer your question:
http://www.databison.com/index.php/excel-color-palette-and-color-index-change-using-vba/
Sub change_palette_color
dim color_index as long
color_index = 10
ActiveWorkbook.Colors(color_index) = RGB(128, 128, 128)
End sub
It turns out all I had to do is change a few numbers in the code i posted in my question. I bolded the numbers I had to change. These numbers correspond to the color ID (like what Belisarious put). NOTE: I had to put apostrohpes so that the VBA code wouldn't be recognized as VBA code (because if it is it won't bold the numbers). See the original question for the correct code.
Dim r As Long, val As Long, c As Long
'r = 1
'val = ActiveSheet.Cells(r, 1).Value
'c = 4
'For r = 1 To ActiveSheet.Rows.Count
If IsEmpty(ActiveSheet.Cells(r, 1).Value) Then
Exit For
End If
' If ActiveSheet.Cells(r, 1).Value <> val Then
If c = 3 Then
c = 4
Else
c = 3
End If
End If
ActiveSheet.Rows(r).Select
With Selection.Interior
.ColorIndex = c
.Pattern = xlSolid
End With
val = ActiveSheet.Cells(r, 1).Value
Next
End Sub