Excel macro : compare cell value with external filename/folder content - excel

I need to complete this code, can you help me?
I have to use it inside an Excel macro.This macro have to check if what is written in each cell (inside them there are song names) is present in a specific folder in the form of files. For example if in a cell there is "Nothing Else Matter", the script will have to check if in that folder there is a file with that name. This is a script that should allow me to save time, I apologize for the errors but it is the first time I put my hand to this language (not my work, I say it for fairness).
The error that comes out is as follows:
Compilation error:
Syntax error
The problem is on the line with "If Dir(songname) "" Then"
Sub Test_if_File_exists_in_dir()
Dim RangeOfCells As Range
Dim Cell As Range
Dim songname As String
Dim TotalRow As Long
TotalRow = Range("A" & Rows.Count).End(xlUp).Row
Set RangeOfCells = Range("A2:A" & TotalRow)
For Each Cell In RangeOfCells
songname = "C:\Alessio\Songs\" & Cell & ".*"
If Dir(songname) "" Then
Cell.Font.Color = vbRed
Else
Cell.Font.Color = vbBlack
End If
Next Cell
MsgBox "Done, verify data first time"
End Sub
Thank you,
Alessio

Try this:
Sub Test_if_File_exists_in_dir()
Dim RangeOfCells As Range
Dim Cell As Range
Dim songname As String
Dim TotalRow As Long
TotalRow = Range("A" & Rows.Count).End(xlUp).Row
Set RangeOfCells = Range("A2:A" & TotalRow)
For Each Cell In RangeOfCells
'edit: include artist
songname = "C:\Alessio\Songs\" & _
Cell.Offset(0, 1) & " - " & Cell & ".*"
Debug.print "Checking: " & songname
Cell.Font.Color = IIf(Len( Dir(songname) ) = 0, vbRed, vbBlack)
Next Cell
MsgBox "Done, verify data first time"
End Sub

Related

Text To Column with Comma Loop Generating Error when run, but not in debug

I am attempting to loop through data in a sheet and split them on a comma, when I run the script I get a Run Time Error '1004' Application-Defined or Object defined error.
However, When I step into the script to debug and run it step by step it works perfectly. I was wondering if anyone has seen this and could help me in fixing it.
Sub PopulatePayrollForm()
Dim s As String: s = "Payout Review"
If DoesSheetExists(s) Then
Dim BottomRow As Long
Dim c As Range
Dim splitv() As String
Sheets("Pay Form").Range("A6:AR1000").ClearContents
'Copy to another sheet, Split Columns, Copy and paste full name into 2 cells
Worksheets("Payout Review").Range("A2:A1000").Copy Worksheets("Pay Form").Range("AQ6:AQ1006")
BottomRow = Worksheets("Pay Form").Cells(Rows.Count, "AQ").End(xlUp).Row
Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow).Activate
For Each c In Selection
splitv = Split(c.Value, ",")
If UBound(splitv) > 0 Then
c.Offset(0, -1).Value = splitv(1)
c.Offset(0, -1).Value = c.Offset(0, -1).Value
c.Value = splitv(0)
End If
Next c
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Copy Worksheets("Pay Form").Range("C6:C" & BottomRow)
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Clear
'Copy and paste Employee Id, Payout AMount, Date Range
Worksheets("Payout Review").Range("B2:B1000").Copy Worksheets("Pay Form").Range("A6:A" & BottomRow)
Worksheets("Payout Review").Range("AB2:AB1000").Copy
Sheets("Pay Form").Range("B6:B" & BottomRow).PasteSpecial xlPasteValues
Worksheets("Payout Review").Range("AD1").Copy Worksheets("Pay Form").Range("J6:J" & BottomRow)
Worksheets("Payout Review").Range("AE1").Copy Worksheets("Pay Form").Range("K6:K" & BottomRow)
Sheets("Pay Form").Visible = True
Else
MsgBox "Data Does not exist"
End If
End Sub
Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
The problem is the use of Selection (and Activate):
For Each c In Selection
Just use the Range in question:
For Each c In Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow)
I recommend reading this for a comprehensive discussion of how to avoid Select.

Apply IF to range of cells in excel VBA

I'm trying to have the following code applied to cells 19:500 in Column I. If I remove the set Range line of code, I19 updates properly but Once i add the range, the following code stops working? Does anyone know where I'm going wrong? Thanks!
Sub Status_Load()
Dim Cell As Range
Dim Range As Range
Dim Today As Date
With Sheet1
Set Range = .Range("I19:I500")
For Each Cell In Range
If Range("N19").Value = Empty Then Exit Sub
If Range("O19").Value <> Month(Today) Then
Range("I19").Value = "Carried"
ElseIf Range("S19").Value <> "" Then
Range("I19").Value = "Closed"
Else: Range("I19").Value = "Open"
End If
Next Cell
End With
End Sub
Use a regular For...Next loop and loop the rows:
Dim i as Long
For i = 19 to 500
If IsEmpty(.Range("N" & i).Value) Then Exit Sub
If .Range("O" & i).Value <> Month(Date) Then
.Range("I" & i).Value = "Carried"
ElseIf .Range("S" & i).Value <> "" Then
.Range("I" & i).Value = "Closed"
Else
.Range("I" & i).Value = "Open"
End If
Next
Side notes (as mentioned in comments):
Dim Range As Range: bad idea. Don't reuse members of the object model as variable names.
If you don't add the . in front of each Range call within the loop, then you're not actually referencing the With Sheet1.
Dim Today As Date. Perhaps you didn't include the line in your question Today = Date? In any case, you can just drop that variable and use Date directly, i.e. Month(Today) --> Month(Date).
EDIT:
As discussed in the comments, you may just be able to use a formula here and avoid VBA:
=IF(S66<>"","Closed",IF(AND(O66<>"",OR(MONTH(O66)<>MONTH(TODAY()),YEAR(O66)<>YEAR(TODAY()))),"Carried",IF(N66<>"","Open","")))

add items in a combobox

I'm trying to add items from a file saved in path "C:\Users\se72497\Desktop" which contains in the 1st column of the sheet called "Departamentos" a series of values I want to add in the Combobox.
My combobox receive the name of dept.
Private Sub UserForm_Initialize()
Dim filename As Workbook
Set filename = Workbooks.Open("C:\Users\se72497\Desktop\Tablas_Macro.xlsx")
With filename.Sheets("Departamentos")
dept.List = Range("A2", .Range("A" & Rows.Count).End(xlUp).Value)
End With
End Sub
I've tried to execute this code but it returns me a run-time error:
Why vba returns me this error?
The .Value is in the wrong place. (Or you could say that the parenthesis is in the wrong place). Correcting this, you have:
.Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
With your current code, .Value is within the Range call, so you're trying to use the value of the cell, not the cell itself, as the 2nd argument.
You want it outside.
Otherwise, if the last cell's value is "foo", then your code is equivalent to
Range("A2", "foo")
which is most certainly not what you want.
So when you click pn your combo box data will get loaded,
' Pre-requisties name the cell A2 with variable rstart
Private Sub UserForm_Initialize()
Dim ws As Worksheet: Set ws = Worksheets("Departamentos")
Dim i As Integer: i = 0
Dim lRow As Long
Dim sAddress As String
On Error GoTo errhandling
If Me.nameofcombobox.Value = vbNullString Then
MsgBox "Select value to continue!"
Else
With ws
lRow = .Range("Departamentos").Rows.Count
'name the cell a2 as rstart
Do Until .Range("rStart").Offset(0, i).Value = Me.nameofcombobox.Value
i = i + 1
Loop
sAddress = .Range("rStart").Offset(0, i - 1).Address
.Range(sAddress & ":" & Left(sAddress, 4) & lRow).Value = .Range(sAddress & ":" & Left(sAddress, 4) & lRow).Value
End With
End If
On Error GoTo 0
MsgBox "Completed without errors", vbInformation, "Success"
FunctionOutput:
Set ws = Nothing
Exit Sub
errhandling:
MsgBox "The following error occurred: " & Err.Description, vbCritical, "Error"
Resume FunctionOutput
End Sub

Implement search box into current worksheet with macro

My macro currently works by pressing CTRL+F to open the search box which searches either REF1 or REF2. If the information is found, it copies over to the next cell basically to show it's there. If the information is not found, it pastes the data searched for in cell L4 so a label can be printed.
What I'm trying to do:
Remove the CTRL+F and basically run from a cell (let's say cell L18). However, when scanned the scanner basically types in the numbers then presses enter/return.
I was wondering, would it be possible to make it run like this.
Select cell L18 then keep scanning until either:
A) The list is done - nothing is missing
B) If REF1/REF2 doesn't match, pastes that data into cell L4 for a label to be printing.
(Current version using CTRL+F): http://oi39.tinypic.com/mima9x.jpg
(Example of what I need): http://oi42.tinypic.com/24fiwt1.jpg
Current macro:
Sub Extra_Missing_Item() Application.ScreenUpdating = False
Dim rangeToSearch As Range
With Sheets(1)
Set rangeToSearch = .Range("A2:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Dim searchAmount As String
searchAmount = InputBox("Scan the REF1 or REF2:")
Dim cell As Range
Set cell = rangeToSearch.Find(searchAmount, LookIn:=xlValues)
With Sheets(1)
If Not cell Is Nothing Then
.Range("E" & cell.Row & ":G" & cell.Row).Value = _
.Range("A" & cell.Row & ":C" & cell.Row).Value
Else
MsgBox "REF1/REF2: " & searchAmount & " shouldn't be here"
.Range("L4").Value = searchAmount
Range("L9").Select
End If
End With
Application.ScreenUpdating = True
End Sub
I think I understand what you need. This macro calls each time any cell on the sheet changed (but if changed cell is not L18, macro do nothing):
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("L18")) Is Nothing Then
Exit Sub
End If
Dim rangeToSearch As Range
Dim searchAmount As String
Dim cell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set rangeToSearch = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row)
searchAmount = Target.value
Set cell = rangeToSearch.Find(searchAmount, LookIn:=xlValues)
If Not cell Is Nothing Then
Range("E" & cell.Row & ":G" & cell.Row).value = _
Range("A" & cell.Row & ":C" & cell.Row).value
Else
MsgBox "REF1/REF2: " & searchAmount & " shouldn't be here"
Range("L4").value = searchAmount
End If
Range("L18").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Put this macro in the Sheet module (coresponding to the sheet where your data is):

Excel 2010 VBA scripting

I’m a complete newbie with VBA but have managed to cobble together the following which works fine for my worksheet where I have assigned the code to a command button. My problem is that my worksheet has in excess of 3000 rows and I don’t really want to create 3000 buttons.
My current thinking would be to have a script search a range of cells for a specific condition (i.e. TRUE) then run my original code as a subscript for each cell that matches the condition. I have tried creating a loop to match the condition being searched but don't know how to set the result(s) as an active cell.
Could anyone give me some pointer on how to achieve this or propose a better solution?
Thanks.
Sub Send_FWU_to_E_Drive()
Dim aTemp As String
Dim bTemp As String
Dim cTemp As String
Dim dTemp As String
Dim eTemp As String
Dim subdir As String
aTemp = "c:\test\"
bTemp = "E:\romdata\"
cTemp = ActiveCell.Offset(, -5) & ".fwu"
dTemp = ActiveWorkbook.path
eTemp = "\Firmware files"
subdir = "\Firmware Files\" & ActiveCell.Offset(, -5) & "\" & ActiveCell.Offset(, -5) & ".fwu"
MsgBox "The path of the active workbook is " & dTemp & subdir
If Dir(dTemp & subdir) = "" Then
MsgBox "Please check the file and ensure it is suitable for firmware updating with an SD card."
Exit Sub
End If
MsgBox "The file " & cTemp & " is being copied to " & bTemp
If Dir("e:\romdata", vbDirectory) = "" Then MkDir "E:\romdata"
If Dir(bTemp & "nul") = "" Then
MsgBox "The Destination Directory is missing, please ensure your SD Card is formatted, mapped as drive E and has a romdata directory."
Exit Sub
End If
FileCopy dTemp & subdir, bTemp & cTemp
End Sub
First modify your function to accept a range argument, which we'll call cell:
Sub Send_FWU_to_E_Drive(cell as Excel.Range)
Then change all the ActiveCell references in that Sub to cell.
The sub below loops through each cell in column B of the Active sheet and, if it's TRUE, calls your routine with the cell in column A of that row. So your offsets in the code in Send_FWU_to_E_Drive are all relative to the cell in column A. This code is untested, but should be close:
Sub Test
Dim Cell as Excel.Range
Dim LastRow as Long
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlup).Row
For Each Cell in .Range("B2:B" & LastRow) 'Search for TRUE in column B
If Cell.Value = TRUE Then
Send_FWU_to_E_Drive cell.Offset(0,-1) 'Column A Cell
End If
Next Cell
End With
End Sub
EDIT: Per #Siddharth's suggestion, here's a Find/FindNext version:
Sub Test()
Dim cell As Excel.Range
Dim LastRow As Long
Dim SearchRange As Excel.Range
Dim FirstFindAddress As String
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set SearchRange = .Range("B2:B" & LastRow) 'Search for TRUE in column B
Set cell = SearchRange.Find(what:=True, after:=SearchRange.Cells(1))
If Not cell Is Nothing Then
FirstFindAddress = cell.Address
Send_FWU_to_E_Drive cell.Offset(0, -1)
Do
Send_FWU_to_E_Drive cell.Offset(0, -1)
Set cell = SearchRange.FindNext(after:=cell)
Loop While Not cell Is Nothing And cell.Address <> FirstFindAddress
End If
End With
End Sub

Resources