Im trying to create a function which scans a column (job-trav-seq) and splits the values in each cell within a given range. It then compares these values to comparable cells in separate columns (so for instance job-trav-seq would have a cell 58546-05-10; this function would remove the dashes and compare the 58546 to job number, 05 to traveller ID and 07 to sequence No.
Basically, the function needs to first takes the A column (JobTravSeq) and breaks it apart into individual variables. (variable 1 should be compared with values in column B, values in variable 2 should be compared with column C and values in variable 3 should be compared with column D)
A loop should go up through the column cells as long as variable 1 = values in column B and variable 2 = values in column C (this is rowStart); this should be stored as a variable
A second loop should occur (rowEnd); which should loop down though the column cells as long as variable 1 = values in column B and variable 2 = values in column C; this should be stored as a variable
The code should then traverse between rowStart and rowEnd and check if variable 3 = values in column D, if it does then place an asterisk (or something similar) in front of the value to mark it as a current task
What im starting with: Sample Doc
What im trying to achieve: SampleDocOutput
any help would be most appreciated
heres my code for reference:
Sub SampleDocOrganise()
Dim i As Integer
Dim LastRow, rowCompare As Long
Dim variArr, rowStart, rowEnd, rangeID As Variant
Dim JobTravSeqRng As Range, jobNoRng As Range, TravellerRng As Range,
opSeqRng As Range, _
rng_JobTravSeq As Range, rng_JobNo As Range, rng_Traveller As Range,
rng_opSeq As Range
Set JobTravSeqRng = Range("A:A")
Set jobNoRng = Range("B:B")
Set TravellerRng = Range("C:C")
Set opSeqRng = Range("D:D")
For Each JobTravSeq In Selection
Str_Array = Split(JobTravSeq, "-")
For h = 0 To UBound(Str_Array)
Range("A:A").Find (Str_Array)
Range.Offset(, h + 1) = Str_Array(h)
For rowStart = 4 To Rows.Count
If Worksheets("Sheet1").Cells(Str_Array, 1).Value = jobNoRng.Value Then
If Cells(Str_Array, 2).Value = jobNoRng.Value Then
Cells.Value = rowStart
End If
End If
Next rowStart
For rowEnd = LastRow To 4 Step -1
If Cells(Str_Array, 1).Value = Range("B:B").Value Then
If Cells(Str_Array, 2).Value = Range("C:C").Value Then
Cells.Value = rowEnd
End If
End If
Next rowEnd
For rowCompare = rowStart To rowEnd
For Each opSeqArr In Str_Array
If Cells(Str_Array, 3).Value = Range("D:D").Value Then
If Cells(Str_Array, 1).Value = Range("B:B") Then
ActiveCell.Characters(0, 0).Insert (" P ")
With ActiveCell.Characters(0, Len(" P ")).Font
.Name = "OpSeq_Equals"
.Bold = True
.Color = -16776961
End With
MsgBox cell.Value = "*" & ""
' if cell changes then go to next loop
Else
' if cell changes then go to next loop
End If
End If
Next
Next
Next h
Next
End Sub
Sub MsgboxTasks() 'should display all rows that contain an asterisk in opSeq (current tasks)
End Sub
Related
I would like to loop through the rows and columns (range B3:I16) of an excel worksheet. If the cell value matches my column p, I would like to color the background of the cell the color of the corresponding hex code (column O) or rgb codes (columns L:M).
I am seeing a compile error at the line "Next j" that says "Next without for" which I assume means there's an error in the previous line. I could not resolve that error.
Once I get the code to work, is there a more efficient way to check all the values in column P without a huge if else statement?
Sub format_quilt()
Dim i, j As Long
'psuedo code python style
'for i in range column number max
' for j in range row number max
' if (cell value == to index name in p4:p14) or (cell directly above == index name in p4:p14)
' color current cell using hex number
For i = 3 To Range("R2").Value
For j = 2 To Range("R1").Value
If (Cells(i, j).Value = Range("P4").Value) Or (Cells(i - 1, j).Value = Range("P4").Value) Then
Cells(i, j).Interior.Color = RGB(Range("L4").Value, Range("M4").Value, Range("n4").Value)
Next j
Next i
End Sub
You can use Match() to check your list in Col P.
For example (copying the fill color from the matched cell):
Option Explicit
Sub format_quilt()
Dim c As Range, ws As Worksheet, m, rngList As Range
Dim i As Long, j As Long
Set ws = ActiveSheet 'or some specific sheet
Set rngList = ws.Range("P4:P14") 'lookup range
For i = 3 To ws.Range("R2").Value
For j = 2 To ws.Range("R1").Value
Set c = ws.Cells(i, j)
m = Application.Match(c.Value, rngList, 0)
If Not IsError(m) Then 'got a match?
c.Interior.Color = rngList.Cells(m).Interior.Color
Else
c.Interior.ColorIndex = xlNone 'clear if no match
End If
Next j
Next i
End Sub
I have two ranges as showed in this picture.
I'm trying to write a VBA macro that successively selects a single cell in the first range (“B23, F27”) , copies the selected cell's value, then selects a random cell in the second range (“G23, K27”), and pastes the first cell's value into the randomly selected cell in the second range.
This should repeat until every cell from the first range has been copied, or every cell in the second range is filled with a new value. In this example both outcomes are equivalent as both ranges have the same number of cells (25).
The result should be like the second image.
I tried to assign the first range to an array and then pick a random value from this array and paste it to the second range.
I also tried to extract unique values from the first range, build a dictionary with it then pick a random cell from the second range and a random value from the dictionary and paste it.
Later I tried again using the VBA syntax “with range” and f"or each cell in range" but I can’t just come up with something that actually works. Sometimes the second range is filled by various values, but not as intended.
First example: this one just does not work
Sub fillrange()
Dim empty As Boolean
'This part checks if every cell in the first range as a value in it
For Each Cell In Range("B23", "F27")
If Cell.Value = "" Then
empty = True
End If
Next
'If every cell is filled then
If empty Then
Exit Sub
Else:
With ThisWorkbook.Worksheets("Sheet1)").Range("B23", "F27")
.Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
.Copy 'the cell select works, but it will copy all range
'This does not work
'For Each Cell In Range("G23", "K27")
'Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
'.PasteSpecial Paste:=xlPasteValues
'Next
End With
End If
End Sub
Second example: it fills the range but with wrong values
Sub fillrange2()
Dim empty As Boolean
For Each cell In Range("B23", "F27")
If cell.Value = "" Then
empty = True
'This part checks if every cell in the first range as a value in it
Exit For
End If
Next cell
If empty Then
Exit Sub
Else:
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection, itm As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
On Error Resume Next
col.Add .Range("B23", "F27").Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
Dim MyAr() As Variant
ReDim MyAr(0 To (col.Count - 1))
For i = 1 To col.Count
MyAr(i - 1) = col.Item(i)
Next
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End If
End Sub
Third example: as the second example, it fills the range but with wrong values
Sub fillrange3()
Dim MyAr() As Variant
MyAr = Range("B23", "F27")
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End Sub
Maybe something like this ?
Sub test()
Set Rng = Range("G23:K27")
n = 1
totCell = 25
Set oFill = Range("G23")
Set oSource = Range("B23")
For i = 1 To 5
oFill.Value = "X" & n
oFill.AutoFill Destination:=Range(oFill, oFill.Offset(4, 0)), Type:=xlFillSeries
Set oFill = oFill.Offset(0, 1)
n = n + 5
Next i
For i = 1 To 5
Do
RndVal = Int((totCell - 1 + 1) * Rnd + 1)
xVal = "X" & RndVal
Set C = Rng.Find(xVal, lookat:=xlWhole)
If Not C Is Nothing Then
C.Value = oSource.Value
Set oSource = oSource.Offset(1, 0)
check = check + 1
If check = 5 Then Exit Do
End If
Loop
Set oSource = oSource.Offset(-5, 1)
check = 0
Next i
End Sub
I cheat by making a preparation for the range G23 to K27 fill with X1 to X25 in the first for i = 1 to 5.
The second for i = 1 to 5 is to offset from column B to G.
The Do - Loop is to generate random number between 1 to 25.
If the generated number is found then the found cell has the value from the "source",
if not found, it loop until the generated number is found 5 times (hence also the found cell is fill with 5 different source). Then before the next i, the "source" cell is offset to the next column.
This if I'm not wrong to get what you mean.
Here's another approach, just for a bit of variety.
Sub x()
Dim r1 As Range, r2 As Range, i As Long
Dim r As Long, c As Long
Set r1 = Range("B23").Resize(5, 5) 'define our two ranges
Set r2 = Range("G23").Resize(5, 5)
r2.ClearContents 'clear output range
With WorksheetFunction
Do Until .Count(r2) = r2.Count 'loop until output range filled
r = .RandBetween(1, 25) 'random output cell number
If .CountIf(r2, r1.Cells(i)) = 0 Then 'if not in output range already
If r2.Cells(r) = vbNullString Then 'if random cell empty
r2.Cells(r).Value = r1.Cells(i).Value 'transfer value
i = i + 1
End If
End If
Loop
End With
End Sub
I have written this code to add numbers in a column. It is not adding the last cell.
For example if there are three numbers 1, 2 and 3 it will sum up 1 and 2 and ignore value in third cell. When there is a fourth number 1, 2, 3 and 4 it adds 1, 2 and 3.
Sub add()
Dim Rng As Range, a As Integer
Set Rng = Range("b2", Range("b2").End(xlDown))
Counter = Rng.Count
a = 0
For i = 2 To Counter
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
Let's say the Counter = Rng.Count gives 4, and you start your i = 2 (possibly to keep title of your column). Your code will not print 4 digits, because you start loop from 2.
The counter should look like this:
Counter = Rng.Count + 1
and it will work
It is because .End(xlDown) - it works like CTRL + downarrow, and ends on the last not empty, or first not empty cell in the column. That's why when you delete value in specific row it will "break" the range. If you want to scan all rows, no matter if it's empty or not use the loop from the first row, and you will get the sum of the whole column range (starting from row 2 of course):
Sub SumWholeColumn()
'give the sum of all numbers in column B, starting from B2
Dim i, a As Long
Dim column, addr As String
a = 0
column = "b"
For i = 2 To Rows.Count
addr = column & i
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
If your range is fixed, you can speed up the calculation process by setting the range manually. Otherwise it will scan ALL rows. For example if you know, that your random numbers will not exceed row 1000, then you can use something like this:
Sub SumWholeColumn()
'give the sum of all numbers in column B, starting from B2
Dim i, a As Long
Dim maxRows As Integer
Dim column, addr As String
a = 0
column = "b"
maxRows = 1000
For i = 2 To maxRows
addr = column & i
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
Well I think that at the first time I did not understood your point then, I thought you would like to paste numbers in column B from 0 to the last row, starting from the B2 address. If so - this will work:
Sub add()
Dim i, a As Long
Dim column As String
Dim addr As String
a = 0
column = "b"
For i = 2 To Rows.Count
addr = column & i
ActiveSheet.Range(addr).Value = a
a = a + 1
Next i
End Sub
but today I realised that your title "Adding numbers in a column via Excel VBA
" is wrong and probably you are trying to achieve something else (because you are trying to give some value in ActiveCell?) and if so, please correct me:
you have actually some numbers in column B, and you would like to give in the ActiveCell the sum of all those numbers? The answer for this will be:
Sub SumAll()
'give the sum of all numbers in column B, starting from B2
Dim Rng As Range
Dim a, i As Long
Set Rng = Range("b2", Range("b2").End(xlDown))
Counter = Rng.Count + 1
a = 0
For i = 2 To Counter
a = a + Cells(i, "B").Value
Next i
ActiveCell.Value = a
End Sub
You need to use "a" as Long, because Integer is up to 2147483647 and if you fill all rows in the column, starting from 0 and iterate the number by 1 to the last row, and sum the values it will give you 2147319811 - out of the Integer scope.
i value can be Integer (not Long as in my example), because "i" max value will not exceed the scope (Workbook rows are limited to 1048576). You can safely change i to Integer and save some KB's of memory :)
So i found this script on this site to color rows with the same cell-data and change the color when the celldata changes and it seems to work just fine, but i have two minor issues
It seems to only apply to the first 900 rows (I have an excel list with 8000+ rows)
It colors the entire row, is there a way to make it only color a certain part of the row?
Thanks in advance! here's the script:
Public Sub HighLightRows()
Dim i As Integer
i = 2 'start at 2, cause there's nothing to compare the first row with
Dim c As Integer
c = 2 'Color 1. Check http://dmcritchie.mvps.org/excel/colors.htm for color indexes
Do While (Cells(i, 1) <> "")
If (Cells(i, 1) <> Cells(i - 1, 1)) Then 'check for different value in cell A (index=1)
If c = 2 Then
c = 37 'color 2
Else
c = 2 'color 1
End If
End If
Rows(Trim(Str(i)) + ":" + Trim(Str(i))).Interior.ColorIndex = c
i = i + 1
Loop
End Sub
Try this:
Public Sub HighLightRows()
Const START_ROW As Long = 2 '<< use a Constant for fixed values
Const VALUE_COL As Long = 1
Dim rw As Range, emptyCells As Long, i As Long, currentValue, tmp
Dim arrColors
arrColors = Array(37, 2)
Set rw = ActiveSheet.Rows(START_ROW)
currentValue = Chr(0) 'dummy "current value"
Do While emptyCells < 10 'quit after 10 consecutive empty cells
tmp = rw.Cells(VALUE_COL).Value
If Len(tmp) > 0 Then
If tmp <> currentValue Then
i = i + 1
currentValue = tmp 'save the new value
End If
'assign the color to a specific set of cells in the row
' starting at cell 1 and 5 columns wide
rw.Cells(1).Resize(1, 5).Interior.ColorIndex = arrColors(i Mod 2)
emptyCells = 0 'reset empty row counter
Else
emptyCells = emptyCells + 1 'increment empty row counter
End If
Set rw = rw.Offset(1, 0) 'next row
Loop
End Sub
It looks like the code only evaluates if the cell is the same as the cell above it. Conditional formatting, as John Coleman said, would be more effective. With it values in the whole column can be evaluated instead of just adjacent ones. And, if I'm not mistaken, there's a setting to look for dup values since Excel 2007, so there doesn't have to be some kind of formula kung-fu to do it.
Unless I'm missing something, it's as simple as Conditional Formatting -> Highlight Cell Rules -> Duplicate Values.
I was looking for some help on creating a sub which does data validation on the values in column C in a worksheet 'Compare' based on possible values listed in a different worksheet 'mapping' in columns C, D, E etc. I wanted to have the possible values use string/pattern characters like # ? * to make the data validation more flexible. There could be anywhere from 1 to 5+ different possible values which varies by key. Validation differences would be spit into an empty column D in worksheet Compare.
An Example with Data is likely most helpful here.
Static sheet 'mapping' . Key is Column A. Possible values in Columns C onwards
A B C D E F G
v1 CDID #### ###? 0
c52 FHAID ER# EP# INVA Z*
c48 PLID *
v24 CUSTID ### ###Q ###P
c22 MATID ???# ??# ?#
q23 LKKID *
Input original sheet 'Compare'. Key is Column B. Column C contains Data to validate
A B C D
c22 MATID RT3FG
v24 CUSTID 456P
v1 CDID 5
q23 LKKID PORTA
Output sheet 'Compare'. Invalid values noted in Column D.
A B C D
c22 MATID RT3FG Error: Invalid value
v24 CUSTID 456P
v1 CDID 5 Error: Invalid Value
q23 LKKID PORTA
Any ideas on how to make this work? Compare worksheet will have all data starting in A1 with no headers. mapping sheet will be quite large with 100+ rows and probably requires a vlookup or similar to find correct row.
Assuming * is anything # is a number and ? is a char I came up with this
Sub CompareToMapping()
Dim mapSheet As Worksheet: Set mapSheet = Sheets("Mapping")
Dim compSheet As Worksheet: Set compSheet = Sheets("Compare")
Dim mcell As Range
Dim ccell As Range
Dim rcell As Range
'Loop throw all the rows in the compare sheet
For Each ccell In compSheet.Range("a1", compSheet.Range("a" & compSheet.Rows.Count).End(xlUp))
'loop through and find a matching row from Mapping sheet
For Each mcell In mapSheet.Range("a1", mapSheet.Range("a" & mapSheet.Rows.Count).End(xlUp))
If mcell = ccell And mcell.Offset(0, 1) = ccell.Offset(0, 1) Then
'loop through valid format strings
For Each rcell In mapSheet.Range(mcell, mapSheet.Cells(mcell.Row, mapSheet.Columns.Count).End(xlToLeft))
ccell.Offset(0, 3) = "Error: Invalid value"
If FormatCorrect(ccell.Offset(0, 2).Text, rcell.Offset(0, 2).Text) Then
'show error in column d
ccell.Offset(0, 3) = ""
Exit For
End If
Next rcell
Exit For
End If
Next mcell
Next ccell
End Sub
Function FormatCorrect(inString As String, inFormat As String) As Boolean
Dim i As Integer: i = 0
Dim curS, curF As String
FormatCorrect = True
' first check for *
If inFormat = "*" Then
FormatCorrect = True
' next check if strings are the same length
ElseIf Len(inString) <> Len(inFormat) Then
FormatCorrect = False
Else
'compare 1 character at a time
For i = 1 To Len(inString)
curS = Mid(inString, i, 1)
curF = Mid(inFormat, i, 1)
If curF = "?" Then ' needs to be a letter
If IsNumeric(curS) Then
FormatCorrect = False
Exit For
End If
ElseIf curF = "#" Then ' needs to be a number
If Not IsNumeric(curS) Then
FormatCorrect = False
Exit For
End If
Else ' needs to be an exact match
If curF <> curS Then
FormatCorrect = False
Exit For
End If
End If
Next i
End If
End Function
Tested and worked for me. Good luck :)