VBA Excel Data Validation of - string

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 :)

Related

Split array and compare values to separate columns

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

Copy values from cells in range and paste them in random cell in range

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

Find specific word in column and copy the adjacent value to different column

I need a help in excel VBA
I would need to find a text (header - e.g. Account) The cell with word "Account" will be always in the column C
and copy value from adjacent column C and paste them on same sheet to Column A
till the value present in column C (like - 09:00-09:30 till it end )
Column
A B C
Account Test1
Group XXX
Date Mon24 Jun, 2019
09:00-09:30
09:30-10:00
10:00-10:30
10:30-11:00
11:00-11:30
11:30-12:00
12:00-12:30
12:30-13:00
13:00-13:30
17:30-18:00
Account Test2
Group YYY
Date Mon24 Jun, 2019
09:00-09:30
09:30-10:00
10:00-10:30
10:30-11:00
11:00-11:30
11:30-12:00
12:00-12:30
12:30-13:00
13:00-13:30
17:30-18:00
Try this..
Sub ApplyHeader()
Dim c As Range, Acc$, Grp$
'Loops through first to last used i column C
For Each c In Range(Cells(1, 3), Cells(Rows.Count, 3).End(xlUp))
'Stores value from adjacent cell if it says "Account".
If c.Value = "Account" Then Acc = c.Offset(, 1).Value
'Stores value from adjacent cell if it says "Group".
If c.Value = "Group" Then Grp = c.Offset(, 1).Value
'Applies stored values in columns to the left if first character is numerical.
If IsNumeric(Left(c.Value, 1)) Then
c.Offset(, -2).Value = Acc
c.Offset(, -1).Value = Grp
End If
Next c
'Removes stored values from "memory".
Acc = "": Grp = ""
End Sub
#AsUsual
I have found d way -->
Sub Copy()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Input")
Set Target = ActiveWorkbook.Worksheets("Output")
j = 1
For Each c In Source.Range("C1:C4000")
If IsNumeric(Left(c.Value, 1)) Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub

Excel VBA Type mismatch error

I am trying to compare the values from one column of one sheet, with the values of another column of a different sheet, same workbook, though. It steps through each cell in the other column, and if the cell value, a string, does not exist in sheet2, then the row from sheet1 is copied over to sheet3. You can think of it like I'm comparing two arrays. I want to see if there are any values in Array1 that do not appear in Array2, and if they do not appear in Array1, the value is copied into Array3.
My main issue is I'm getting a type-mismatch error in line 5. The values contain strings. I am fairly new at Excel VBA and am trying to learn it on the fly. Any help would be greatly appreciated.
Sub search()
Dim count As Integer
count = 0
For Each i In Worksheets("Sheet1").Range("C2:C4503")
Set first_cell = Worksheets("Sheet1").Cells(i, 3) <-- Mismatch eror
For Each j In Worksheets("Sheet2").Range("X2:X4052")
Set second_cell = Worksheets("Sheet2").Cells(j, 24)
If second_cell = first_cell Then Exit For
Next j
count = count + 1
Set Worksheets("Sheet3").Cells(count, 1) = Worksheets("Sheet1").Cells(j, 1).Select
Next i
End Sub
Sub Search()
Dim rowNum As Long
Dim i As Range, f As Range
rowNum = 1
For Each i In Worksheets("Sheet1").Range("C2:C4503").Cells
If Len(i.Value) > 0 Then
'search for value on sheet2
Set f = Worksheets("Sheet2").Range("X2:X4052").Find( _
i.Value, , xlValues, xlWhole)
If f Is Nothing Then
'not found: copy row from sheet1>sheet3
i.EntireRow.Copy Worksheets("Sheet3").Cells(rowNum, 1)
rowNum = rowNum + 1
End If
End If
Next i
End Sub
The following:
For Each i In Worksheets("Sheet1").Range("C2:C4503")
...
Next i
iterates through the cells in the specified range; i is a Range object representing the current cell.
You are using it as in integer index in the following line:
Set first_cell = Worksheets("Sheet1").Cells(i, 3)
Hence the Type Mismatch.

Excel VBA Macro: Creating a Macro That Extracts Duplicate Record and Pastes into New Sheet

I have been trying to create a simple macro that takes all duplicate records from a source sheet and pastes them into a new sheet.
I have been messing around, and the closest I've gotten is the creation of a list that extracts all duplicate values except for the first duplicate value in a cluster.
So for example, if a list looks like this below:
1
1
2
3
4
5
1
The sheet with the duplicates will list:
1
1
It will consider the first instance of '1' as unique, and that is totally not what I want. I want it to show every single instance of the duplicated row, so I awnt this:
1
1
1
Here's what I do to deal with duplicates. It isn't a macro, but works for me:
Sort the column with the duplicate. (For this example, say column C)
In a new column, write an IF function. Eg in cell D5: =if(c5=c4,1,"")
Copy cell D5 to the entire list.
Copy and paste value column D over itself. Eg in step 2, the formula is replaced with a "1"
Sort column D
Any row with a 1 is a duplicate. Do as you wish!
You can also do things like find the sum of column D (shows me how many duplicates)
After clarifications by OP the following procedure will perform as required:
Sub CopyDuplicates()
'***************************************************************
'** This proc expects you to select all the cells in a single **
'** column that you want to check for duplicates in. If dup- **
'** licates are found, the entire row will be copied to the **
'** predetermined sheet. **
'***************************************************************
Dim ShO As Worksheet
Dim Rng1 As Range
Dim pRow As Integer
Dim c As Range, cTmp As Range
Dim found
Dim Addresses() As String
Dim a() As String
Dim p2 As Integer
Dim tfFlag As Boolean, sTmp As Variant
Set ShO = Worksheets("Sheet2") 'You can change this to whatever worksheet name you want the duplicates in
Set Rng1 = Application.Selection 'Rng1 is all the currently selected cells
pRow = 1 'This is the first row in our outpur sheet that will be used to record duplicates
ReDim a(0) 'Initialize our array that holds found values
For Each c In Rng1.Cells 'Cycle through each cell in our selected range
ReDim Addresses(0) 'This array holds the cell address for our duplicates.
'We will reset the array each time we move to the next cell
'Now check the array of already found duplicates.
'If the current value is already there skip to next value
tfFlag = False
For Each sTmp In a
If CStr(c.Value) = sTmp Or CStr(c.Value) = "xXDeleteXx" Then 'We've already done this value, move on
tfFlag = True
Exit For
End If
Next
If Not tfFlag Then 'Remember the flag is true when we have already located the
'duplicates for this value, so skip to next value
With Rng1
Set found = .Find(c.Value, LookIn:=xlValues) 'Search entire selected range for value
If Not found Is Nothing Then 'Found it
Addresses(0) = found.Address 'Record the address we found it
Do 'Now keep finding occurances of it
Set found = .FindNext(found)
If found.Address <> Addresses(0) Then
ReDim Preserve Addresses(UBound(Addresses) + 1)
Addresses(UBound(Addresses)) = found.Address
End If
Loop While Not found Is Nothing And found.Address <> Addresses(0) 'Until we get back to the original address
If UBound(Addresses) > 0 Then 'We Found Duplicates
a(UBound(a)) = c.Value 'Record the value we found a duplicate for in an array
ReDim Preserve a(UBound(a) + 1) 'add an empty spot to the array for next value
ShO.Range("A" & pRow).Value = "Duplicate Rows for Value " & c.Value & _
" in Column " & c.Column & " on original sheet" 'Add a label row
pRow = pRow + 1 'Increment to the next row
For p2 = UBound(Addresses) To 0 Step -1 'Cycle through the duplicate addresses
Set cTmp = Rng1.Worksheet.Range(Addresses(p2)) 'we just want to easily get the correct row to copy
Rng1.Worksheet.Rows(cTmp.Row).Copy ShO.Rows(pRow) 'Copy form orig to duplicates sheet
cTmp.Value = "xXDeleteXx" 'Mark for Delete the original row
pRow = pRow + 1 'Increment row counter
Next p2
pRow = pRow + 1 'This increment will give us a blank row between sets of dupicates
End If
End If
End With
End If
Next
'Now go delete all the marked rows
Do
tfFlag = False
For Each c In Rng1
If c.Value = "xXDeleteXx" Then
Rng1.Worksheet.Rows(c.Row).Delete (xlShiftUp)
tfFlag = True
End If
Next
Loop Until tfFlag = False
End
End Sub

Resources