I've been making what started out as a basic asset tracker, but as its progressed more and more has been added.
before this I've never done anything with excel, meaning most of what i have done has been through searching, copying, and making slight changes to code found online.
Im now trying to search for a client name held on a "Database" sheet and display all assets assigned to that client on a "Reports" sheet
I have "Userform5" with a command box auto populating the name of the client as you begin typing
Client name is often referred to differently, so the official client name is loaded into the command box, however on the spreadsheet it may have been inputted as a shortened version of the name. Eg, Tarmac Trading Limited is the official name loaded into the command box, on the Database this may be input as just Tarmac or another slight variation.
i have a code that works fine, but only for exact matches, and will even disregard if a space has been entered at the end of the client name on "database"
is there a way to change the below code to search for partial matches?
Sub ClientSearch_Click()
Application.ScreenUpdating = False
Dim Client As String
Dim finalrow As Integer
Dim i As Integer
Sheets("Reports").Range("A2:aj10000").ClearContents
Client = Trim(Cmbclient.Text)
Sheets("Database").Activate
finalrow = Sheets("Database").Range("A10000").End(xlUp).Row
For i = 2 To finalrow
'Function equalsIgnoreCase(str1 As String, str2 As String) As Boolean
' equalsIgnoreCase = LCase(str1) = LCase(str2)
'End Function
If LCase(Sheets("Database").Cells(i, 4)) = LCase(Client) Then
Range(Cells(i, 1), Cells(i, 50)).Copy
Sheets("Reports").Range("A100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Sheets("Reports").Activate
Range("A:AZ").EntireColumn.Hidden = True
Range("B:B,D:D,E:E,F:F,G:G,H:H,I:I,J:J,K:K,L:L,M:M,N:N,Q:Q,AB:AB,AF:AF,AG:AG,AH:AH,AI:AI,AJ:AJ").EntireColumn.Hidden = False
Application.ScreenUpdating = True
Unload UserForm5
End Sub
Replace
If LCase(Sheets("Database").Cells(i, 4)) = LCase(Client) Then
with
If LCase(Sheets("Database").Cells(i, 4)) = LCase(Client) Or InStr(LCase(Client), LCase(Sheets("DataBase"), Cells(i, 4))) > 0 Then
Related
I am getting completely crazy about this issue, please help me.
I have made a shell script that writes in a text file the path of some images that are stored in a folder. Then I use an excel code to read each path and write it in an excel cell.
I have then made a code that should take that path and use it to insert the picture. I have tried with Pictures.insert(path) and shapes.addpictures "path", but I have the same issue every time, the picture can't be loaded.
What's weird, is that, if I manually insert the picture before and then delete it, the code will perfectly load the picture. But if it's the first time then no.
The paths that I'm using look like that: "/Users/theodorebedos/Documents/code_tilly/new_pict_tilly/IMG_9040.jpg"
I'm using a mac, maybe that matters?
Private Sub Convert_Img()
Dim myPict As Picture
Dim PictureLoc As String
Dim EndPictRow, i As Integer
Dim StartPath As String
If Worksheets("Main").Cells(3, 1).Value <> "" Then
EndPictRow = Worksheets("Main").Range("A2").End(xlDown).Row
For i = 3 To EndPictRow
PictureLoc = Worksheets("Main").Cells(i, 1).Value
Worksheets("Main").Cells(i, 1).ClearContents
Worksheets("Main").Cells(i, 1).ColumnWidth = 30
Worksheets("Main").Cells(i, 1).RowHeight = 150
ActiveSheet.Shapes.AddPicture PictureLoc, False, True, Worksheets("Main").Cells(i, 1).Left, Worksheets("Main").Cells(i, 1).Top, Worksheets("Main").Cells(i, 1).Width, Worksheets("Main").Cells(i, 1).Height
Next i
End If
End Sub
Edit:
When I use "Pictures.insert" or "shapes.addpicture path, true, true " I have no error message in VBA but I have in excel instead of my picture, a blank image with inside an error message like this:
image
If I use "shapes.addpicture path, FALSE, true" then I have an error message like this but no image at all is loaded: image 2
And then an error 1004 like that:
image3
And if I do the process to have image 1, then I save the document, reopen it, I'll have this directly: image 4
Thanks for you help. It will be much appreciated.
I streamlined your code so it becomes possible to see what it's doing. Note that I avoided reading values from the cell's properties which were just set or are obvious.
Once the column width has been set, the width of all cells in it are the same.
The Left property of all cells in a column is always the same.
If the column is column A, the Left is always 0.
Of course, what you tried to achieve is to enter a value only once. That is good practice but to read properties from the sheet is slow. The faster way - less code volume and better readable, too - is to declare a constant at the top and use that name in the code.
So you end up with this code.
Private Sub Convert_Img()
Const ClmWidth As Single = 30
Const RowHight As Single = 150
Dim EndPictRow As Long, R As Long
' sorry, I recommend i for arrays and R for rows (C for columns)
With Worksheets("Main")
' End(xlDown) will find the first blank cell below the base cell.
' There might be more filled cells further down.
' End(xlUp) will find the first used cell above the base cell
' disregarding more blanks above that one.
EndPictRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' no need to set the column width multiple times in the loop
.Columns(1).ColumnWidth = ClmWidth
' this loop will never run if R < EndPicRow
For R = 3 To EndPictRow
With .Cells(R, 1)
.RowHeight = RowHight
' this will work only once:-
.Worksheet.Shapes.AddPicture CStr(.Value), False, True, 0, .Top, ClmWidth, RowHight
End With
Next R
End With
End Sub
The reason why it works only once becomes quite obvious. The new picture takes its source path from the cell's Value. Of course, once you insert a picture (image) in the cell that value can't be the path (string) anymore. If you run the code a second time it will fail. However, if that is your need, it should be possible to extract the path from the formula that defines the picture in the cell. Given that the picture itself isn't present at that location the formula should either hold the path or a reference to a location within the workbook's background data, depending upon how it was loaded.
Ok, so it's not perfect yet, but I put the loop off and I used Dir() as you said #Variatus.A pop-up window like this opened when I executed the command Dir(). It asked me the authorisation to access the file. I pressed yes and then it worked.
It worked but only for that file. So I guess, I am on the right way now and I need to find how to give access to all the files in that folder before running the code. I can't do it for all of them.
Thank you very much.
I hope someone will benefit from this old thread. As it turns out this is some sort of a permission issue also noted already in one of the comments, possibly only occurring with Excel 16 macros on OSX.
It seems like Excel is lacking the permissions to access the resources linked and is not asking for them. We need to grant permissions to all files in the folder. The following code demonstrates how to achieve this, given the identifier to build the paths is in Column A2:20. Run this macro (adjust the way the path is built), then grant access once the dialogue appears:
Sub GrantAccess()
Dim cName As Variant
Dim files() As Variant
Set xRange = ActiveSheet.Range("A2:A20")
For Each cell In xRange
ReDim Preserve files(1 To cell.Row - 1)
cName = "/Users/adjust-your-path/path" & Cells(cell.Row, "A") & "_thumb_600.png"
files(cell.Row - 1) = cName
Next
fileAccessGranted = GrantAccessToMultipleFiles(files)
End Sub
Code used:
Sub URLPICInsertMM()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
Dim cName As String
Dim img As Picture
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("B2:B10")
For Each cell In xRange
'cName = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
' files are located in thumbs sub-directory
cName = "/Users/.../IonChannels/thumbs/" & Cells(cell.Row, "A") & "_thumb_300.png"
Set img = ActiveSheet.Pictures.Insert(cName)
img.Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
Cells(cell.Row, "C").Value = "file://" & cName
Set cRange = Cells(cell.Row, cell.Column)
With cShape
.LockAspectRatio = msoTrue
'If .Width > cRange.Width Then .Width = cRange.Width
If .Height > cRange.Height Then .Height = cRange.Height
.Top = cRange.Top + (cRange.Height - .Height)
.Left = cRange.Left + (cRange.Width - .Width)
End With
line22:
Set cShape = Nothing
Range("T2").Select
Next
Application.ScreenUpdating = True
End Sub
Edit:
Evidence:
I created a simple test sheet (the idea is to load some protein visualization thumbs into an excel sheet) with an identifier in Column A, image file descriptors are constructed from the identifier + path and file extension.
The image is inserted into Column B and the file descriptor as text into Column C.
When I ran the macro for the first time, only the first image was loaded. Excel formats the file descriptor as a hyperlink. When clicking the file:///... link, Excel opens a dialog that asks to grant permissions to that file (screenshot). If I grant access and accept warnings, then run the macro again, the image appears.
After running macro again, image is displayed:
Hello stackoverflow users,
I am facing the following problem, I receive a very big Excel table every day and would like to simplify it. So I decided to automatize this task, I wrote a VBA script and saved it as a module.
I open and execute it, sometimes it works. I am searching for hours already for any hint.
Function HideRows()
ActiveSheet.Rows("2:2").EntireRow.Hidden = True
ActiveSheet.Rows("5:5").EntireRow.Hidden = True
ActiveSheet.Rows("8:8").EntireRow.Hidden = True
ActiveSheet.Rows("10:10").EntireRow.Hidden = True
ActiveSheet.Rows("11:11").EntireRow.Hidden = True
ActiveSheet.Rows("24:24").EntireRow.Hidden = True
ActiveSheet.Rows("29:29").EntireRow.Hidden = True
ActiveSheet.Rows("30:30").EntireRow.Hidden = True
ActiveSheet.Rows("31:31").EntireRow.Hidden = True
ActiveSheet.Rows("37:37").EntireRow.Hidden = True
End Function
Function HideColumns()
Dim rng As Range
For Each rng In Range("C:J").Columns
rng.EntireColumn.Hidden = True
Next rng
For Each rng In Range("L:M").Columns
rng.EntireColumn.Hidden = True
Next rng
End Function
Function FilterByAttributes()
beginRow = 1
EndRow = Cells(Rows.Count, 1).End(xlUp).row
ActiveSheet.Range("K" & EndRow).AutoFilter Field:=11, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
End Function
Private Sub CommandButton1_Click()
Call HideColumns
Call HideRows
Call FilterByAttributes
End Sub
Is there any better possibility to format the table with less amount of clicks according to the conditions in my script?
UPDATE: the algorithm of my actions:
Download excel table from my email
Open this excel table
Open "Developer tools tab"->Visual Basic-> File-> Import->Select module->Execute Module. This step has to be somehow simplified, have no ideas how
Continue working with the resultant table
I would like to make as less clicks as possible for the "special filter"
Thanks in advance
Some thoughts:
1) Consider adding the macro to a personal workbook instead of importing it every day to a new excel file.
2) You don't need a loop to hide columns: ActiveSheet.Columns("C:J").Hidden = True, and similarly for .Columns("L:M").
3) The Call keyword can be dropped.
4) Add Option Explicit to the top of the module and declare all variables, specifically beginRow and EndRow.
I have replicated the code in Excel macro to search a website with excel data and extract specific results and then loop for next value, although I get a error on the line URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2 stating "object variable or with block variable not set"
So I am just trying to replicate the code for another website.
This code pulls in a certain text and spits out a value from the webiste.
So I would like to enter in MFR SKU in sheet 1 as such:
Name // SKU // Price
WaterSaverFaucet // SS902BC
After I have created a macro button on sheet 2 and clicking it
Then have it spit out the price.
So that it ends up like this below:
Name // SKU // Price
WaterSaverFaucet // SS902BC // 979.08
I would need this in order to look up multiple items on a website.
Sub LoopThroughBusinesses1()
Dim i As Integer
Dim SKU As String
For i = 2 To Sheet1.UsedRange.Rows.Count
SKU = Sheet1.Cells(i, 2)
Sheet1.Cells(i, 3) = URL_Get_SKU_Query1(SKU)
Next i
End Sub
Function URL_Get_SKU_Query1(strSearch As String) As String ' Change it from a Sub to a Function that returns the desired string
' strSearch = Range("a1") ' This is now passed as a parameter into the Function
Dim entityRange As Range
With Sheet2.QueryTables.Add( _
Connection:="URL;https://www.neobits.com/SearchBySKU.aspx?SearchText=" & strSearch & "&safe=active", _
Destination:=Sheet2.Range("A1")) ' Change this destination to Sheet2
.BackgroundQuery = True
.TablesOnlyFromHTML = True
.Refresh BackgroundQuery:=False
.SaveData = True
End With
' Find the Range that has "Price"
Set entityRange = Sheet2.UsedRange.Find("Price")
' Then return the value of the cell to its' right
URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2
' Clear Sheet2 for the next run
Sheet2.UsedRange.Delete
End Function
Your logic is flawed unfortunately. You cannot simply take the mechanism from one webpage and assume it works for the next. In this case the solution you are trying will not work. When you enter a SKU into search what actually happens is a page re-direct (302). Not the construction of an url as you have tried. You are getting the error you see primarily due to hitting a page not found - though surfaces due to your element not being found on the 404 page.
Instead, you can use the construct the page in question actually uses for initial url and then you can use xmlhttp which will follow the re-direct as follows:
VBA:
Option Explicit
Public Sub GetPrices()
Dim xhr As XMLHTTP60, html As HTMLDocument, ws As Worksheet, i As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set xhr = New XMLHTTP60
Set html = New HTMLDocument
Dim allData()
allData = ws.UsedRange.Value
With xhr
For i = 2 To UBound(allData, 1)
.Open "GET", "https://www.neobits.com/search?keywords=" & allData(i, 2), False
.send
Dim price As Object
html.body.innerHTML = .responseText
Set price = html.querySelector("#main_price")
If Not price Is Nothing Then
allData(i, 3) = price.innerText
Else
allData(i, 3) = "No price found"
End If
Set price = Nothing
Next
End With
ws.Cells(1, 1).Resize(UBound(allData, 1), UBound(allData, 2)) = allData
End Sub
I assume your page set-up, in Sheet1, is as follows:
Required project references:
The two references bounded in red are required. Press Alt+F11 to open the VBE and then go Tools > References and add references. You may have a different version number for xml library - in which case reference will need changing as will code references of
Dim xhr As XMLHTTP60
and
New XMLHTTP60
To run this code:
Press Alt+F11 to open the VBE > Right click in project explorer > Add standard module. Paste code into that standard module > Select anywhere inside the code and press F5, or hit the green Run arrow in the ribbon.
You could further develop, for example, to handle non 200 status codes:
Option Explicit
Public Sub GetPrices()
Dim xhr As XMLHTTP60, html As HTMLDocument, ws As Worksheet, i As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set xhr = New XMLHTTP60
Set html = New HTMLDocument
Dim allData(), price As Object
allData = ws.UsedRange.Value
With xhr
For i = 2 To UBound(allData, 1)
.Open "GET", "https://www.neobits.com/search?keywords=" & allData(i, 2), False
.send
If .Status <> 200 Then
allData(i, 3) = "Status not succeeded" '<== Little bit loose but you get the idea.
Else
html.body.innerHTML = .responseText
Set price = html.querySelector("#main_price")
If Not price Is Nothing Then
allData(i, 3) = price.innerText
Else
allData(i, 3) = "No price found"
End If
Set price = Nothing
End If
Next
End With
ws.Cells(1, 1).Resize(UBound(allData, 1), UBound(allData, 2)) = allData
End Sub
' Find the Range that has "Entity Type:"
Set entityRange = Sheet2.UsedRange.Find("Lists At:")
' Then return the value of the cell to its' right
URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2
The problem is that Range.Find may not find what you're looking for, for various reasons. Always specify the optional parameters to that function, since it otherwise "conveniently remembers" the values from the last time it was invoked - either from other VBA code, or through the Excel UI (IOW there's no way to be 100% sure of what values it's going to be running with if you don't specify them). But even then, if Range.Find doesn't find what it's looking for, it will return Nothing - and you can't just assume that will never happen!
But, reading closer...
' Find the Range that has "Entity Type:"
Set entityRange = Sheet2.UsedRange.Find("Lists At:")
Someone's lying. Read the comment. Now read the code. Who's telling the truth? Don't write comments that say "what" - have comments say "why", and let the code say "what". Otherwise you have situations like that, where it's impossible to tell whether the comment is outdated or the code isn't right, at least not without looking at the worksheet.
In any case, you need to make sure entityRange isn't Nothing before you try to make a member call against it:
If Not entityRange Is Nothing Then
URL_Get_SKU_Query1 = entityRange.Offset(0, 1).Value2
End If
I hope someone can help- I'm hitting the dreaded "Out of memory or system resources" error with some code running in Excel and working with Outlook; from which the error originates.
Short description is it runs through a list of emails looking in the body/subject for a reference. If it finds it, it forwards the email item with the reference in the subject. MWE below; I'm not very experienced handling Outlook objects but I've spent nearly two hours trying different things with no luck. I can't use the GetTable() function since it doesn't include Body text data as far as I know (working off this), unless you can somehow add columns to include the body text?
If I run it in a freshly-opened Outlook session with only a dozen items it isn't a problem but I need it to work on hundreds of emails in one pop. Banging my head against a wall here. Thanks so much in advance!
Private Sub processMWE(ByVal oParent As Outlook.MAPIFolder)
Dim thisMail As Outlook.MailItem
Dim myItems As Outlook.Items
Dim emailindex As Integer
Dim folderpath As String
Dim refandType As Variant
Dim fwdItem
Set myItems = oParent.Items
folderpath = oParent.folderpath
'Starting at row 2 on the current sheet
i = 2
With myItems
'Data output to columns in Excel
For emailindex = 1 To .Count
Set thisMail = .Item(emailindex)
'i takes row value
Cells(i, 1).Value = folderpath
Cells(i, 2).Value = thisMail.Subject + " " + thisMail.Body
Cells(i, 3).Value = thisMail.SenderEmailAddress
Cells(i, 4).Value = thisMail.ReceivedTime
Cells(i, 6).Value = thisMail.Categories
'Reference from body/subject and a match type (integer)
refandType = extractInfo(Cells(i, 2))
'This is the reference
Cells(i, 5).Value = refandType(0)
'And this is the match type.
Select Case refandType(1)
Case 1, 2
'do nothing
Case Else
'For these match types, fwd the message
Set fwdItem = thisMail.Forward
fwdItem.Recipients.Add "#########"
fwdItem.Subject = Cells(i, 5) & " - " & thisMail.Subject
fwdItem.Send
'Edit original message category label
thisMail.Categories = "Forwarded"
thisMail.Save
'Note in spreadsheet
Cells(i, 7).Value = "Forwarded"
End If
End Select
i = i + 1
Next
End With
End Sub
Edit: New development: not only is it always hanging on the same line of code (thisMail.Body) it's actually doing it for specific mail items?! If I give it a batch of one of these problem messages it hangs immediately. Could it be something to do with character encoding or message length? Something that means thisMail.Body won't work that triggers a resources error?
Reason of the problem:
You are creating items without releasing them from memory -with these lines-
For emailindex = 1 To .Count
Set thisMail = .Item(emailindex)
Solution
Release the objects once you are done with them
End Select
i = i + 1
Set thisMail = Nothing
Next
End With
Common language explanation
In this scenario, think about VBA as a waiter, you are telling it that you are going to give some dishes to serve to the customers, you are giving all of them to it, but you never tell it to release them to the table, at one point, it will not be able to handle any more dishes ("Out of memory")
I believe I have thoroughly researched this question (sorry if you have seen the answer, please be patient with me).
Truly a newcomer to VBA/Macros and do not even fully understand where to "put" the codes that are provided in these message boards, that is why I prefer a formula.
My sheet has cells which feed to a hyperlink (i.e. A1=JFK, B1:CVG, C1=HYPERLINK("http://www.gcmap.com/dist?p="&A1&"-"&B1,"My Flight").
If you visit the link (http://www.gcmap.com/dist?P=jfk-cvg) it shows the flying distance between these two points - 589 mi.
What I am trying to do is do a web query in Excel based off the link provided in cell C1, and then have the web query point to the total distance included in the link - and then populate another cell on my sheet (D1) with that distance.
Any and all help would be appreciated!
How's something like this:
Sub getMiles()
'Thanks to http://stackoverflow.com/questions/16975506/how-to-download-source-code-from-a-website-with-vba for idea
Dim k As Long, s
Dim URL2 As String
Dim ws As Worksheet, newWS As Worksheet
Set ws = ActiveSheet
Application.ScreenUpdating = False
URL2 = ws.Cells(1, 3) 'Cell C1 is the URL
' to get data from the url we need to creat a win Http object_
' tools > references > select Windows Win Http Services 5.1
Dim Http2 As New WinHttpRequest
'open the url
Http2.Open "GET", URL2, False
' send request
Http2.Send
'MsgBox Http2.ResponseText
Debug.Print s
'Debug.Print Http2
Debug.Print URL2
Dim Resp As String: Resp = Http2.ResponseText
Dim Lines2 As Variant: Lines2 = Split(Resp, ">")
Worksheets.Add after:=Sheets(Sheets.Count)
Set newWS = ActiveSheet
newWS.Name = "Temp for source code"
k = 0
For k = LBound(Lines2) To UBound(Lines2)
newWS.Cells(1 + k, 1).Value = Lines2(k)
k = k + 1
Next k
Dim findString As String, stringCell As Range
findString = " mi"
Set stringCell = newWS.Columns(1).Find(what:=findString)
Dim milesFlown As String
milesFlown = Left(stringCell.Value, WorksheetFunction.Search("&", stringCell, 1) - 1)
'MsgBox ("You would fly " & milesFlown)
ws.Cells(1, 4).Value = milesFlown
Application.DisplayAlerts = False
newWS.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
It's sort of roundabout, but what it does is get the source code of your URL, and in that source code, look for a string that only seems to occur before the miles are given (" mi"), then finds the numbers to the left of the &, and sets that as your miles. You will need to tweak the macro to correctly point to the cell with your URL. Let me know if you need any help doing so!
edit: Ah, to use this code, with Excel open, press ALT+F11, this will open up the VB editor. I think you can insert this code (just copy/paste) into the "Sheet1 (Sheet1)" part. If not, you'll need to right click "VBAProject ([yourbook])" and Insert Module, and put the code there. It should then show up in your macro list (View tab --> Macros).
Edit2: Also, you'll need to add a Reference most likely in VBA. Press ALT+F1 to open VB Editor, then in Tools -> References, look for "Microsoft WinHTTP Services, version 5.1" and add a check mark, and click "Ok" to add this reference. Otherwise, you'll get an error.
Edit3: Updated the code. It now puts the source code on a new sheet, so anything you have in Col. A won't be deleted.