I am trying to create some automatism on my excel database.
In this case increment a value if another cell is populated.
Example:
Start a count starting at A21 if B21 contains a number or text.
The count will stop if there is no value on the B adjacent cell.
A B
21 1 Text 1
22 2 Text 2
23 3 Text 3
24
25
So far I got this:
Sub Macro1()
Dim r1 As Range, r2 As Range, cell As Range, mynumber As Long
Set r1 = Range("B21:B2642")
Set r2 = Range("A21:A2642")
mynumber = 1
For Each cell In r1
If cell.Value <> "" Then
cell.Value("A21:A2642") = mynumber
mynumber = mynumber + 1
End If
Next
End Sub
Bests
Work with this,
Sub Button1_Click()
Dim rw As Long, rng As Range, c As Range
rw = 2642
Set rng = Range("B21:B" & rw)
For Each c In rng.Cells
If c <> "" Then
If c.Row = 21 Then
c.Offset(, -1) = 1
Else
c.Offset(, -1) = c.Offset(-1, -1) + 1
End If
End If
Next c
End Sub
Related
I tried this, which returned the rows I want, so a good start. But I really just need the value in Column B, not the entire row. What I really want is to list the value in column B if the value in column C is <>"" and column D <>"". Results in Quote sheet starting in cell C4.
Sub CopyQuoteValues()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Software Options").UsedRange.Rows.Count
B = Worksheets("Quote").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Quote").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Software Options").Range("C17:C" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) <> "" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Quote").Range("A" & B + 1)
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Something like this should do what you need:
Sub CopyQuoteValues()
Dim wsOpt As Worksheet, wsQuote As Worksheet
Dim c As Range, rngDest As Range
Set wsOpt = Worksheets("Software Options")
Set wsQuote = Worksheets("Quote")
Set rngDest = wsQuote.Range("C4")
For Each c In wsOpt.Range("C17", wsOpt.Cells(wsOpt.Rows.Count, "C").End(xlUp)).Cells
If Len(c.Value) > 0 And Len(c.Offset(0, 1)) > 0 Then 'value in C and D ?
c.Offset(0, -1).Copy rngDest 'copy ColB
Set rngDest = rngDest.Offset(1, 0) 'next paste location
End If
Next c
End Sub
I want to read through multiple cells in a row and depending if they are all formatted green, turn a separate cell green.
If one cell in the row is either red or has no colour the cell will remain with red or no colour, then loop through my table to read each row and return a format in one column of cells.
And when I click my update button which brings new data into the table, the column of cells will reset to no colour then be formatted.
[![enter image description here][1]][1]
Sub CS_Click()
Range("D6:D37").Interior.ColorIndex = 0
Dim Range1 As Range
Dim Range2 As Range
For RR = 1 To 33
For CC = 1 To 31
Set Range1 = Cells(RR + 5, CC + 6)
Set Range2 = Cells(RR + 5, CC + 3)
If Range1.Interior.ColorIndex = 0 Then
Range2.Interior.ColorIndex = 0
ElseIf Range1.Interior.ColorIndex = 38 Then
Range2.Interior.ColorIndex = 38
ElseIf Range1.Interior.ColorIndex = 50 Then
Range2.Interior.ColorIndex = 50
End If
Next
Next
End Sub
I think you could use something like the following. This will loop through a range and test each row in the range for the ColorIndex of that row. It will then update a destination row with the ColorIndex of your choice
Sub CS_Click()
Dim rng As Range, RowRng As Range
Dim c As Range
Dim RowNo As Long
Dim ClrIndex As Long
Dim ChangeClr As Boolean
' The range of your source data
Set rng = ActiveSheet.Range("G6:AM37")
For Each c In rng.Columns(1).Cells
ClrIndex = -4142
ChangeClr = False
RowNo = c.Row - rng.Cells(1).Row + 1
On Error Resume Next
Set RowRng = Nothing
Set RowRng = rng.Rows(RowNo).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not RowRng Is Nothing Then
Select Case RowRng.Interior.ColorIndex
' Case 50
Case 50
ClrIndex = 50
ChangeClr = True
' Blank rows
Case -4142
ChangeClr = False
' Others not defined, Null (Mixed color rows) and color 38 rows
Case Else:
ClrIndex = 38
ChangeClr = True
End Select
If ChangeClr = True Then
' Update the 'rng.Coloumns.Count + 1' with the offset of your destination cell
c.Offset(0, -3).Interior.ColorIndex = ClrIndex
End If
End If
Next c
End Sub
I think your code can be simplified to:
Sub CS_Click()
Range("D6:D37").Interior.ColorIndex = 0
For RR = 1 To 33
Set Range2 = Cells(RR + 5, 4)
For CC = 1 To 31
Set Range1 = Cells(RR + 5, CC + 6)
c = Range1.Interior.ColorIndex
If c = 38 Or c = 50 Then
Range2.Interior.ColorIndex = c
Exit For ' remove this line as necessary
End If
Next
Next
End Sub
If you leave the Exit For line in, then the colour in column D will change based on the first pink or green cell it gets to. If you remove it, it will change the colour on each pink or green cell - resulting in column D representing the last green or pink colour it detected.
I currently have a macro that copies the value from a specific cell from one sheet(BACKEND), and pastes in specific column in another sheet (EXPORT_DATA), in the next blank row.
Sub copy_values(Optional Source As String = "A1", Optional Source2 As String = "A1")
Dim R As Range
Dim col As Long
col = Range(Source).Column
Set R = Worksheets("EXPORT_DATA").Cells(Rows.Count, col).End(xlUp)
If Len(R.Value) > 0 Then Set R = R.Offset(1)
R.Value = Worksheets("BACKEND").Range(Source2).Value
End Sub
It works well, but I want to replace the the function in where it pastes the data in the next blank cell in a column, to a function in where it pastes the data in a row in where a cell holds a specified value.
For example, the older function would do the following
step 1:
c1 c2 c3
a b 4
c d 6
step 2 (after macro executed):
c1 c2 c3
a b 4
c d 6
c d 5
But I need a new function that does this:
step 2 (C1 value of "c" specified, macro executed):
c1 c2 c3
a b 4
c d 5
See how this goes for you. Not sure how you are calling etc but it should be a reasonable starting point. I only gave it a really quick test
Sub copy_values_SINGLE(cValue As Variant, Optional Source As String = "A1", Optional Source2 As String = "A1")
' Not sure of what value type c in your question would be but expects a single value to test against the column provided as Source
' Requires cValue to be provided
Dim R As Range
Dim col As Long
Dim destRow As Integer
col = Range(Source).Column
On Error Resume Next
destRow = 0
destRow = Worksheets("EXPORT_DATA").Columns(col).Find(cValue, SearchDirection:=xlPrevious).Row
If destRow = 0 Then destRow = Worksheets("EXPORT_DATA").Cells(Rows.Count, col).End(xlUp).Row + 1 ' if cValue isnt found reverts to the last row as per previous code
On Error GoTo 0
Set R = Worksheets("EXPORT_DATA").Cells(destRow, col)
R.Value = Worksheets("BACKEND").Range(Source2).Value
End Sub
This may work
Sub copy_values(Optional Source As String = "A1", Optional Source2 As String = "A1")
Dim R As Variant
Dim col As Long
col = Range(Source).Column
Dim mrn As String
Dim FoundCell As Excel.Range
Dim myVal As String
R = Worksheets("BACKEND").Range(Source2).Text
myVal = Worksheets("BACKEND").Range(Source2).Text
mrn = Worksheets("BACKEND").Range("A5").Value
Set FoundCell = Worksheets("EXPORT_DATA").Range("A:A").Find(what:=mrn, lookat:=xlWhole, searchdirection:=xlPrevious)
If Not FoundCell Is Nothing Then
' MsgBox (R & " " & col & " " & FoundCell.Row)
Worksheets("EXPORT_DATA").Range("Q" & FoundCell.Row).Value = R
Else
MsgBox "error"
End If
End Sub
Still not 100% certain, but I think this is what you are after. The file loop all values in column A of the EXPORT_DATA file and compared them to the value in cell A1 of the BACKEND worksheet. If it finds the value it replaces the value in column B, if it cannot find the value, it adds it at the end:
Sub copy_values_SINGLE()
Dim R As Range
Dim rowCount As Long
Dim varValue As Variant
rowCount = Application.WorksheetFunction.CountA(Worksheets("EXPORT_DATA").Range("A:A"))
For s = 1 To rowCount
If Worksheets("EXPORT_DATA").Range("A" & s).Value = Worksheets("BACKEND").Range("A1").Value Then
Worksheets("EXPORT_DATA").Range("A" & s & ":B" & s).Value = Worksheets("BACKEND").Range("A1:B1").Value
Exit For
Else
If s = rowCount Then
Set R = Worksheets("EXPORT_DATA").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
R.Value = Worksheets("BACKEND").Range("A1:B1").Value
End If
End If
Next s
End Sub
Let me know if this works for you.
Hi all I am trying to make a vb macro that determins are there 4 empty cells in a row if so it should put 0 in a next row otherwais 1 Here is what I 've done so far
Sub QuickCull()
On Error Resume Next
Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
Columns("b").SpecialCells(xlBlanks).EntireRow.Delete
Columns("d").SpecialCells(xlBlanks).EntireRow.Delete
Dim col As Range
Set col = Cells(Rows.Count, "E").End(xlUp)
Dim r As Range
Set r = Range("E2", col).Resize(, 4)
r.Select
Dim cell As Range
For Each cell In r
If cell.Value = "" Then
cell.Value = 0
Else
cell.Value = 1
End If
Next cell
End Sub
This way I put 0 instad of one blank row I thought about making another cell with a sum of those rows, but is where a way to do it more queckly and productivly?
I think you need something like the following, obviously replace "WORKSHEETNAME" with the name of the worksheet:
Dim r as Range, cell as Range, eRow as Long
eRow = Sheets("WORKSHEETNAME").Cells(Rows.Count, 5).End(xlUp).Row
Set r = Sheets("WORKSHEETNAME").Range("E2:E" & eRow)
For each cell in r.cells
If cell.Offset(0,-4).Value = "" _
And cell.Offset(0,-3).Value = "" _
And cell.Offset(0,-2).Value = "" _
And cell.Offset(0,-1).Value = "" Then
cell.Value = 0
Else
cell.Value = 1
End if
Next cell
I would appreciate your help with the following:
I would like to compare two columns, let us say Column A and Column B, **looking for duplicates**.
If a value in Column A has a match value in Column B, I would like to format the cells of the same duplicate value with the color (the colors are random and different for each match).
This is if `A12 = B30`, the color will be red. And if `A20 = B1`, the color is green and so on.
If there is no match just leave it as it.
That was only an example for red and green. let say you have two columns (A and B).
A1 = 1000
A2 = 2000
A3 = 3000
A4 = 4000
A5 = 5000
A6 = 6000
A7 = 7000
A8 = 8000
A9 = 9000
B1 = 1500
B2 = 9000
B3 = 5000
B4 = 3500
B5 = 7500
B6 = 1000
B7 = 4000
So you have several matches and I need each match to be in random different colors. For example:
A1 = B6 –> They will be colored/highlighted in green
A4 = B7 –> They will be colored/highlighted in red
A5 = B3 –> They will be colored/highlighted in yellow
A9 = B2 –> They will be colored/highlighted in pink
The colors will be different for any match and the non-match will be color less or no change.
I wish this will explain the question and this has to be using excel.
{
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant for at
Dim LstRw As Long
Dim c As Range, clr As Long, x
Set sh = ActiveSheet
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:B" & LstRw)
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For Each c In Rng.Cells
If c = vNum Then
x = Application.WorksheetFunction.CountIf(Rng, vNum)
If x > 1 Then c.Interior.ColorIndex = clr "error here: the code runs fine for around 50 lines then it is stoppedand gives error and pointing to this line"
//Error shows in pop window: Run-time error 'g': Subscript out of range
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
}
This is an adjusted code from my answer here.
https://stackoverflow.com/a/33798531/1392235
Loop through the cells to find the unique values, then loop through the unique values to color the duplicates.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim LstRw As Long
Dim c As Range, clr As Long, x
Set sh = ActiveSheet
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:B" & LstRw)
Set cUnique = New Collection
Rng.Interior.ColorIndex = xlNone
clr = 3
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
For Each c In Rng.Cells
If c = vNum Then
x = Application.WorksheetFunction.CountIf(Rng, vNum)
If x > 1 Then c.Interior.ColorIndex = clr
End If
Next c
clr = clr + 1
Next vNum
End With
End Sub
Results
Sample Workbook
EDIT:
Using colorindex limits us to 56 colors, if we use RGB we can increase that. Edit this part of the code, you will have to play with the values get the color variances you like.
If x > 1 Then c.Interior.Color = 1000000 + clr * 100
End If
Next c
clr = clr + 255