I'm trying to turn certain cells red based on information from a single row and column. What my algorithm is supposed to do is search through the single column and find a matching string and save that the column number, then do the same for the row. Then the script selects the cell and turns it red.
All the keys that I search for come from a piece of code that I found online and modified to suit my needs. It works perfectly. The problem is I can't get the search to work properly.
Option Explicit
Sub Blahbot()
Dim xRow As Long
Dim x As Long, y As Long
Dim xDirect$, xFname$, InitialFoldr$, xFF$
InitialFoldr$ = "G:\" '<<< Startup folder to begin searching from
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7) '<<< Where the search terms come from
Do While xFname$ <> ""
y = Application.WorksheetFunction.Match(Mid(xFname$, 11, 4), Range("D2:KD2"), 0) '<<< Find a matching string in table header
x = Application.WorksheetFunction.Match(Mid(xFname$, 16, 4), Range("B3:B141"), 0) '<<< Find matching string in column B
Cells(x, y).Select '<<<Select the cell and turn it red
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
xFname$ = Dir
Loop
End If
End With
End Sub
What the code does is that it reads through a folder, gets the file names, and splits them up. The name will always be ####_#### (where #=upper case letter and #### is a time in 24-hour format).
The Mid function splits that name up into the 4 letters and the time.
If you understand what I'm trying to do, could you suggest a better search algorithm or see what my code is doing wrong?
I simplified my answer because I may have misunderstood your question. MATCH returns a value relative to the range you look in. So if the match is in Column D, then MATCH returns 1. Therefore, you'll need to offset the returned value.
'Add 2 to x, since we start on 3rd row, add 3 to y since we start on 4th column
Cells(x+2, y+3).Select
You may also want to include code to check if there is no match. To see if you're having this issue, you can use the code below to test for this or add watches.
On Error Resume Next
y = Application.WorksheetFunction.Match(...)
If Err = 0 Then
MsgBox "All is well"
Else
MsgBox "There was an error with Match"
End If
On Error Goto 0
Related
I created a code to get the all the file names in the folder into a worksheet.I use this to check the accuracy of the file names(Please see the diagram below).
When I click the macro file names of the destination folder appear under the system reports.Then I use some formulas to match the file names with "Actual Names" column and indicates it to the user.
There is an issue with my code that the order of the file names displaying in the the worksheet is changing day by day though the file names and the order of the files are same in the destination folder.
How do I solve this problem?
Sub GetFiles_Name()
Dim x As String, y As Variant
x = "D:\Reports\*"
y = GetFileList(x)
Select Case IsArray(y)
Case True
MsgBox UBound(y)
Sheets("Cost").Range("H6:H11").Select
Selection.ClearContents
For i = LBound(y) To UBound(y)
Sheets("Cost").Cells(i, 8).Rows("6").Value = y
Next i
Case False
MsgBox "No Matching Files Found!"
End Select
End Sub
Function GetFileList(FileSpec As String) As Variant
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
NoFilesFound:
GetFileList = False
End Function
I can see several problems with your Sub GetFiles_Name():
The variable y is an array, but you're using it as if it was a variable on this line:
Sheets("Cost").Cells(i, 8).Rows("6").Value = y
When you do that, VBA will take the first element of the y array and use it in each column. Has your code actually ever worked as you show in your picture?
By writing Sheets("Cost").Range("H6:H11").ClearContents you assume that your files will always be 6 (from 6 to 11). Is that really the case? I would rather use something more flexible (here I assume that H5 corresponds to your Actual Names header column):
Dim lastRow As Integer: lastRow = Sheets("Cost").Range("G5").End(xlDown).Row
Sheets("Cost").Range("H6:H" & lastRow).ClearContents
Also notice that you don't need to .Select first and then clear the Selection. You can directly .ClearContents on the range without selecting.
Finally, in order not to be dependent on the order of the System Reports column files, you should look for each file and, if matched, just write it close to it. It would look like this:
For i = LBound(y) To UBound(y)
Set matched = Range("G6:G" & lastRow).Find(y(i), LookAt:=xlWhole) '<-- I assume "G" is the column with the file names moving in order
If Not matched Is Nothing Then '<-- if I found the file in the list
matched.Offset(0, 1) = y(i) '<-- put the file name in the adjacent column H
End If
Next i
I'm working on a excel document being generated with APACHE POI.
The document is filled with many drop down lists for data validation.
The data chosen in those drop down lists are always of the same type:
LABEL (ID)
For the person who fills the excel document, the ID is less important than the LABEL _ but the ID is still necessary for parsing purposes.
I managed through APACHE POI to put a specific format on those kind of cells, in order to help the user to focus on the information more useful to him/her :
LABEL is in black
(ID) is in grey
My problem: when the user change a value in the cell throught the drop down list, the style format is lost on the cell.
My question: is it possible to set up a listener on my excel document that does the folowing job:
on ANY cell
filled through ANY drop down list
on ANY sheet of the workbook
set the specified cell format ?
I already have a function that does the "style format" job, but I don't know how to plug it on this kind of listener...
Function formatStyle()
Dim cellContent As String
Dim valeurLength As Integer
For Each currentCell In Selection.Cells
cellContent = currentCell.Value
For valeurLength = 1 To Len(cellContent)
If Mid(cellContent, valeurLength, 1) = "(" Then
Exit For
End If
Next valeurLength
With currentCell.Characters(Start:=1, Length:=valeurLength - 1).Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
With currentCell.Characters(Start:=valeurLength, Length:=Len(cellContent) - valeurLength + 1).Font
.ThemeColor = xlThemeColorDark1
.Color = -4144960
End With
Next
End Function
Excel Form controls don't support any kind of font and color formatting. ActiveX controls let you change the font and colors, but not of individual characters. Custom drawing parts of the control most likely can be achieved with some complicated VBA and WinAPI calls.
The closest alternative I can think of is some of the bold extended Unicode characters:
Thanks to Determine if cell contains data validation, I've managed to do exactly what I wanted:
Private Sub Workbook_SheetChange(ByVal Sh As Object,ByVal Target As Range)
Dim cell As Range, v As Long
For Each cell In Selection.Cells
v = 0
On Error Resume Next
v = cell.SpecialCells(xlCellTypeSameValidation).Count
On Error GoTo 0
If v <> 0 Then
formatReferenceCell (Target)
End If
Next
End Sub
Function formatReferenceCell(cellContent)
Dim X As Integer
For X = 1 To Len(cellContent)
If Mid(cellContent, X, 1) = "(" Then
Exit For
End If
Next X
With ActiveCell.Characters(Start:=1, Length:=X - 1).Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
With ActiveCell.Characters(Start:=X, Length:=Len(cellContent) - X + 1).Font
.ThemeColor = xlThemeColorDark1
.Color = -4144960
End With
End Function
Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:
99204 - OFFICE/OUTPATIENT VISIT, NEW
will need to be split into
Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW
I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub
The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.
The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.
Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the
Cells(1, a + 3).Value = Trim(name(a))
code, specifically with "Cells()".
Thank you Conrad Frix!
Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub
Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.
Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.
Modified answer to modified request.
This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the
i = 1
line to
i = 2
I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)
Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
If Not Cells(i, 1).Font.Bold Then
initialText = Cells(i, 1).text
name = Split(initialText, "-", 2)
If Not UBound(name) < 1 Then
Cells(i, 1) = Trim(name(0))
Cells(i, 4) = Trim(name(1))
End If
End If
i = i + 1
Loop
End Sub
just add a variable to keep track of the active row and then use that in place of the constant 1.
e.g.
Dim iRow as Integer = ActiveCell.Row
For a = 0 To 1
Cells(iRow , a + 3).Value = Trim(name(a))
Next a
Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.
EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.
Sub tgr()
Const DataCol As String = "A" 'Change to the correct column letter
Const HeaderRow As Long = 1 'Change to be the correct header row
Dim rngOriginal As Range 'Use this variable to capture your original data
'Capture the original data, starting in Data column and the header row + 1
Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data
'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
'We also turn off screenupdating to prevent "screen flickering"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Move the original data to a temp worksheet to perform the split
'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
'Lastly, move the split data to desired locations and remove the temp worksheet
With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
.Value = rngOriginal.Value
.Replace " - ", "-"
.TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
rngOriginal.Value = .Value
rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
.Worksheet.Delete
End With
'Now that all operations have completed, turn alerts and screenupdating back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only
as a formula
=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)
code
Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
.Value = .Value
End With
End Sub
I am trying to compare the values of two cells in two different workbooks (.csv files) that hold special characters (■, □)
The code is to compare the cell content with a reference cell and let the user know if they are the same.
e.g
CASE 1. □□□□□ (FOUND) to ■■■■■ (REFERENCE) --> Different value
CASE 2. ■■■■■ (FOUND) to ■■■■■ (REFERENCE) --> Same value
I have a FOR loop to run through the entries and an IF-statement to perform the comparison. The IF function is suppose check if the cells are equal
Unfortunately, my code keeps determining that the cells are not equal.
i.e CASE 2 keeps producing message feedback "Different Value"
I am unable to find the problem so any help would be appreciated.
Thank you!
[CODE BELOW]
Sub Value_Checker()
Old_Data = Application.GetOpenFilename _
(Title:="Please choose old data to import", _
FileFilter:="CSV Files *.csv (*.csv), ")
If Old_Data = False Then
MsgBox "No file specified.", vbExclamation, "Please pick old data"
Exit Sub
Else
Set OldFile = Workbooks.Open(Old_Data)
End If
Rowlim = 100
ThisWorkbook.Activate
CHECK = Cells(4, 3).Value
OldFile.Activate 'Activates old workbook
For i = 1 To Rowlim
ActiveSheet.Cells(i, 4).Select
If Cells(i, 4) <> CHECK Then
MsgBox "Different Value"
Else
MsgBox "Same Value"
End If
Next i
End Sub
I suggest you try strcomp():
StrComp(Cells(i, 4), CHECK, CompareMethod.Binary)
Some more information here.
I'm relatively new to VBA and I'm trying to write a macro that will compare two columns of data (first and last names). While traversing the column, any time first name = last name (ie. they're both blank or say UNKNOWN) I want the cell in the 9th column to be cleared and the cell in the 10th column to get the value UNKNOWN.
As of now, the code correctly recognizes any time when the first and last name are identical. My problem is that any time first name is a sub-string of any last name (ie. cell I2=David J2=Jones , I3=Joseph J3=Davidson) David gets compared with Davidson and is subsequently erased.
I've spent a while looking for similar problems and I haven't been able to adapt anything to my problem thus far. Thanks in advance for any help.
Sub compare_cols()
Dim Report As Worksheet
Dim i As Integer, j As Integer
Dim lastRow As Integer
Set Report = Excel.ActiveSheet
lastRow = Report.UsedRange.Rows.count
Application.ScreenUpdating = False
For i = 1 To lastRow ' This will find all identical pairs of cells in I,J (blank, blank) or (unknown, unknown). I stays blank, J gets UNKNOWN
For j = 1 To lastRow ' I think its currently erasing any matches (ex. if someones first name is James, it will get erased if there is a last name jameson)
If InStr(1, Report.Cells(j, 10).Value, Report.Cells(i, 9).Value, vbTextCompare) > 0 Then
Report.Cells(i, 9).Value = ""
Report.Cells(i, 10).Value = "UNKNOWN"
Exit For
Else
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Unlike some other languages, you can compare strings in vba just using the "=" sign and that will find exact matches, which is what it appears you are looking for. Try
if Report.Cells(j, 10) = Report.Cells(i, 9) etc.