Column A contains part numbers such as 499305 and 488212
Sub ProductLoopChemSafe()
Dim X As Integer
Dim lRow As Long
Image1 = 250
Image2 = 500
Image3 = 5000
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For X = 3 To lRow
Range("B" & X).Value = "http://www.chemsafeint.com/images/products/" & Image1 & "/" & Range("A" & X).Value & ".gif"
Range("C" & X).Value = "http://www.chemsafeint.com/images/products/" & Image2 & "/" & Range("A" & X).Value & ".gif"
Range("D" & X).Value = "http://www.chemsafeint.com/images/products/" & Image3 & "/" & Range("A" & X).Value & ".gif"
Range("E" & X).Value = "http://www.chemsafeint.com/files/sds/" & Range("A" & X).Value & ".pdf"
Range("F" & X).Value = "http://www.chemsafeint.com/files/pds/" & Range("A" & X).Value & ".pdf"
Range("G" & X).Value = "http://www.chemsafeint.com/files/idf/" & Range("A" & X).Value & ".pdf"
If Range("A" & X) = "17255" Then
Range("H" & X).Value = "http://www.chemsafeint.com/files/eds/" & Range("A" & X).Value & ".pdf"
End If
If Range("A" & X) = "17418" Then
Range("I" & X).Value = "http://www.chemsafeint.com/files/epp/" & Range("A" & X).Value & ".pdf"
End If
If Range("A" & X) = "17750" Then
Range("I" & X).Value = "http://www.chemsafeint.com/files/epp/" & Range("A" & X).Value & ".pdf"
End If
If Range("A" & X) = "17822" Then
Range("I" & X).Value = "http://www.chemsafeint.com/files/epp/" & Range("A" & X).Value & ".pdf"
End If
Next X
End Sub
How can I test to see if a path is valid before I write it?
I'd like to do something like:
DIM Bvalue as string
Bvalue = "http://www.chemsafeint.com/images/products/" & Image1 & "/" & Range("A" & X).Value & ".gif"
If Bvalue is valid then
Range("B" & X).value = Bvalue
Else
Range("B" & X).value = ""
END IF
You can write a function that receive the URL as parameter and validate it with some web-scraping code then returns true or false if the object of the link is valid. something like isObject( html_element )
The HTML element could be an element that loads everytime when the stuff that you are searching exists. For example the following URL https://chemsafeint.com/images/products/500/11999-DM55.gif has the object img inside the HTML code ( if you are not familiar please search Web Scraping with VBA ), then you can try this:
Function isValid ( byVal URL as string )as boolean
'URL is the link that you have just mounted concatenating strings.
Dim IE As InternetExplorer: Set IE = New InternetExplorer
IE.navigate URL
IE.AddressBar = False
IE.Visible = True
Set IEDOC = IE.document
Dim ELE as HTMLImage
Set ELE = IEDOC.getElementsByTagName("img")
if isObject(ELE) then
isValid = true
else
isValid = false
end if
IE.Quit
Set IE = NOTHING
Exit Function
Related
I got stuck on how to implement the logic dynamically.
i'm referencing the source sheet to main page sheet for the cells ranging from c5 to c12, similarly for other cells, eg. n5 to n12.
Sub cellRef()
Dim srcSht As Worksheet, destSht As Worksheet
Set srcSht = ThisWorkbook.Sheets("HR - Source")
Set destSht = ThisWorkbook.Sheets("HR - Main Page")
destSht.Range("C5").Formula = "='" & srcSht.Name & "'!C5"
destSht.Range("C6").Formula = "='" & srcSht.Name & "'!C6"
destSht.Range("C7").Formula = "='" & srcSht.Name & "'!C7"
destSht.Range("C8").Formula = "='" & srcSht.Name & "'!C8"
destSht.Range("C11").Formula = "='" & srcSht.Name & "'!C11"
destSht.Range("C12").Formula = "='" & srcSht.Name & "'!C12"
destSht.Range("N5").Formula = "='" & srcSht.Name & "'!N5"
destSht.Range("N6").Formula = "='" & srcSht.Name & "'!N6"
destSht.Range("N7").Formula = "='" & srcSht.Name & "'!N7"
destSht.Range("N8").Formula = "='" & srcSht.Name & "'!N8"
destSht.Range("N11").Formula = "='" & srcSht.Name & "'!N11"
destSht.Range("N12").Formula = "='" & srcSht.Name & "'!N12"
destSht.Range("M5").Formula = "='" & srcSht.Name & "'!M5"
destSht.Range("M6").Formula = "='" & srcSht.Name & "'!M6"
destSht.Range("M7").Formula = "='" & srcSht.Name & "'!M7"
destSht.Range("M8").Formula = "='" & srcSht.Name & "'!M8"
destSht.Range("M11").Formula = "='" & srcSht.Name & "'!M11"
destSht.Range("M12").Formula = "='" & srcSht.Name & "'!M12"
end sub```
how to make it dynamic, using any loops?
please suggest.
I have working VBA code that pulls information from Excel and autofills a Word document.
I want to add another column/bookmark.
I added new bookmarks in the Word template and added the lines:
.BookMarks("CouncilRegion2").Range.Text = Range("W" & r).Value
.BookMarks("CouncilRegion3").Range.Text = Range("X" & r).Value
I get
'Run-time error '5941': The requested member of the collection does not exist.
I did not write the code, I maintain it and add new lines when needed.
I tried changing the Range.
Private Sub CreateTemplate1(tPath As String, r As Integer)
Dim wdApp As Object
Dim wdDoc As Object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = True
'wdApp.DisplayAlerts = False
Set wdDoc = wdApp.Documents.Open(FileName:=tPath)
With wdDoc
.BookMarks("STPNumber").Range.Text = Range("L" & r).Value
.BookMarks("ProposedUse").Range.Text = Range("L" & r).Value
.BookMarks("SiteAddress").Range.Text = Range("E" & r).Value
.BookMarks("LotRp").Range.Text = Range("O" & r).Value
.BookMarks("hSTPNumber").Range.Text = Range("L1").Value
.BookMarks("hSiteAddress").Range.Text = Range("E" & r).Value
.BookMarks("hLotRp").Range.Text = Range("O" & r).Value
.BookMarks("ClientName").Range.Text = Range("C" & r).Value
.BookMarks("ClientName1").Range.Text = Range("C" & r).Value
.BookMarks("TownPlanner").Range.Text = Range("Q" & r).Value
.BookMarks("ProposedUse1").Range.Text = Range("L" & r).Value
.BookMarks("SiteAddress1").Range.Text = Range("E" & r).Value
.BookMarks("CouncilRegion").Range.Text = Range("P" & r).Value
.BookMarks("CurrentDate").Range.Text = Format(Now(), "dd/mm/yyyy")
.BookMarks("CouncilFee").Range.Text = Range("F" & r).Value
.BookMarks("CouncilFee1").Range.Text = Range("F" & r).Value
.BookMarks("hours").Range.Text = Range("K" & r).Value
.BookMarks("hours1").Range.Text = Range("K" & r).Value
.BookMarks("SiteAddress2").Range.Text = Range("E" & r).Value
.BookMarks("ProposedUse2").Range.Text = Range("L" & r).Value
.BookMarks("SiteAddress3").Range.Text = Range("E" & r).Value
.BookMarks("LotRp1").Range.Text = Range("O" & r).Value
.BookMarks("SiteAddress4").Range.Text = Range("E" & r).Value
.BookMarks("LotRp2").Range.Text = Range("O" & r).Value
.BookMarks("ProposedUse3").Range.Text = Range("L" & r).Value
.BookMarks("CouncilRegion2").Range.Text = Range("W" & r).Value
.BookMarks("CouncilRegion3").Range.Text = Range("X" & r).Value
Dim ourFee As Long, ourTotal As Long
Dim ourGST As Long, ourDeposit As Long
ourFee = Range("G" & r).Value
ourGST = ourFee * 0.1
ourTotal = ourFee + ourGST
ourDeposit = ourTotal * 0.6
.BookMarks("OurFeeGST").Range.Text = Format(ourFee, "#,###.00")
.BookMarks("OurFee").Range.Text = Format(ourFee, "#,###.00")
.BookMarks("OurGST").Range.Text = Format(ourGST, "#,###.00")
.BookMarks("OurTotal").Range.Text = Format(ourTotal, "#,###.00")
.BookMarks("OurDeposit").Range.Text = Format(ourDeposit, "#,###.00")
End With
End Sub
The code opens a Word template that is saved in the same folder, and autofills the document using Bookmarks that have been set up.
It won't autofill the lines that I have added and then comes up with the error.
Try printing out all the bookmark names (to the immediate pane in the VB editor) and make sure you see the ones you added:
'...
'...
Set wdDoc = wdApp.Documents.Open(FileName:=tPath)
Dim bm
For Each bm In wdDoc.Bookmarks
Debug.Print bm.Name
Next bm
'...
'...
I have a master spreadsheet that analyzes records from another spreadsheet with rows going all the way up to 1.4 million.
Below are the relevant pieces from the code:
Sub Whyamidoingthis()
Dim USISINLfp As String
Dim ISINL As String
Dim echeck As String
Dim wUSISIN As Workbook
Dim lastrow As Long
Dim Result As Worksheet
Dim i As Long
Set OutShVar = ThisWorkbook.Worksheets("in1")
ISINL = "CONSOLIDATED - Country_Of_Incorp_US_2019-03-01 (Consolidated).xlsx"
USISINLfp = "W:\Product Platforms\ISIN- CUSIP Country of Incorporation\March 2019\"
Workbooks.Open (USISINLfp & ISINL)
Set wUSISIN = Workbooks(ISINL)
With Result
lastrow = .Cells(.Rows.Count, "H").End(xlUp).Row
End With
'US Security 1
For i = 2 To lastrow
With Result
echeck = Trim(.Range("O" & i))
If echeck = "" Then
.Range("P" & i & ":Q" & i).Value = "N"
Else
.Range("P" & i).Value = "=ifna(vlookup(O" & i & "," & ISINL & "First Sheet'!$B:$C,2,false)," & Chr(34) & "N" & Chr(34) & ")"
.Range("Q" & i).Value = "=ifna(vlookup(O" & i & "," & ISINL & "Second Sheet'!$B:$C,2,false)," & Chr(34) & "N" & Chr(34) & ")"
'Debug.Print "=ifna(vlookup(O" & i & "," & ISINL & "Second Sheet'!$B:$C,2,0)," & Chr(34) & "N" & Chr(34) & ")"
End If
'US Security 2
echeck = Trim(.Range("S" & i))
If echeck = "" Then
.Range("T" & i & ":U" & i).Value = "N"
Else
.Range("T" & i).Value = "=ifna(vlookup(S" & i & "," & ISINL & "First Sheet'!$A:$C,3,false)," & Chr(34) & "N" & Chr(34) & ")"
.Range("U" & i).Value = "=ifna(vlookup(S" & i & "," & ISINL & "Second Sheet'!$A:$C,3,false)," & Chr(34) & "N" & Chr(34) & ")"
End If
End With
Next I
If Not wUSISIN Is Nothing Then wUSISIN.Close savechanges:=False
End Sub
The code is getting stuck at the following line:
.Range("T" & i).Value = "=ifna(vlookup(S" & i & "," & ISINL & "First Sheet'!$A:$C,3,false)," & Chr(34) & "N" & Chr(34) & ")"
Whenever a result is found and the error is application defined error.
Try this formula:
"=ifna(vlookup(O" & i & ",'[" & ISINL & "]First Sheet'!$B:$C,2,false)," & Chr(34) & "N" & Chr(34) & ")"
This places square brackets around the workbook name and single quotes around the workbook-worksheet combo. See this tutorial about using VLOOKUP from another workbook.
firstly i want to write a macro for going through of every row so if valuse of item is more than 10 creat a folder base on values of that rows.in addition without a duplicate folder !
for example if there is item20 then create a folder with this name 20_NT25153_29.9 then another rows
i wanna to add this sentence ,i know my code is very simple but i am new in VBA hence need more help :)
Sub loopthrough()
With Worksheets("Output_" & Date)
fName5 = .Range("d").Value
fName1 = .Range("B").Value
fName2 = .Range("c").Value
fName4 = "_"
BrowseForFolder = CurDir()
End With
For Each cell In ActiveWorkbook.Worksheets
If cell.Range("B").Value > "10" Then
BrowseForFolder1 = BrowseForFolder & "\" & fName1 & fName2 & fName5
MkDir BrowseForFolder1
End If
Next cell
End Sub
You could use this code:
Sub Macro1()
Dim lLastRow As Long
Dim sPath As String, sNewFolder As String
sPath = CurDir()
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lLastRow
If Range("B" & i).Value > 10 Then
sNewFolder = Range("B" & i).Value & "_" & Range("C" & i).Value & "_" & Range("D" & i).Value
If Dir(sPath & "\" & sNewFolder, vbDirectory) = "" Then
MkDir (sPath & "\" & sNewFolder)
End If
End If
sNewFolder = vbNullString
Next
End Sub
Fisrt of all I check for the last row index based on A column, not to loop through whole worksheet.
In a loop I've used a Dir() function with vbDirectory parameter which returns empty string when folder does not exists & in that case it creates a folder.
Is this what you're after?
Folder name is column B value _ column C value _ column D value ?
Sub loopthrough()
Dim cell As Range, fName4
BrowseForFolder = CurDir()
fName4 = "_"
With Worksheets("Output_" & Date)
For Each cell In .Range("B1", .Range("B" & Rows.Count).End(xlUp))
If cell.Value > 10 Then
BrowseForFolder1 = BrowseForFolder & "\" & cell.Value & fName4 & cell.Offset(, 1).Value & fName4 & cell.Offset(, 2).Value
MkDir BrowseForFolder1
End If
Next cell
End With
End Sub
it works for somebody need same as me
Sub Macro1()
Dim lLastRow As Long
Dim sPath As String, sNewFolder As String
sPath = CurDir()
lLastRow = workbooks(sFilename).Sheets(1).Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Workbooks(sFilename).Sheets(1).Activate
For i = 2 To lLastRow
If Workbooks(sFilename).Sheets(1).Cells(i, 2).Value >= 10 Then
sNewFolder = ActiveSheet.Range("B" & i).Value & "_" & ActiveSheet.Range("C" &
i ).Value & "_" & ActiveSheet.Range("D" & i).Value
If Dir(sPath & "\" & sNewFolder, vbDirectory) = "" Then
MkDir (sPath & "\" & sNewFolder)
End If
End If
sNewFolder = vbNullString
Next
End Sub
I've concatenated a string to paste an index match formula into rows of a column. Every time I try running this piece of code, I get Runtime Error '1004, but I can't see what I have wrong. Here's the code I have:
Dim j As Long
'Loop down the rows in mainfile
For j = 2 To lastFullRow2
Dim firstArgument As String
firstArgument = "Sheet2!" & valuecolumnLetter & "2:" & valuecolumnLetter & lastFullRow1 & ""
'MsgBox "firstArgument" & firstArgument
Dim secondArgument As String
secondArgument = "Sheet2!" & parameter1columnLetter & "2:" & parameter1columnLetter & lastFullRow1 & ""
'MsgBox "secondArgument " & secondArgument
Dim thirdArgument As String
thirdArgument = "Sheet2!" & parameter2columnLetter & "2:" & parameter2columnLetter & lastFullRow1 & ""
'MsgBox "thirdArgument " & thirdArgument
Dim fourthArgument As String
fourthArgument = "Sheet2!" & parameter2columnLetter & "2:" & parameter2columnLetter & lastFullRow1 & ""
'MsgBox "fourthArgument " & fourthArgument
Dim condition3 As String
condition3 = "Sheet3!" & "D2:" & D & j & ""
'MsgBox "condition3 " & condition3
Dim patid1 As String
patid1 = "Sheet2!" & "D2:" & D & lastFullRow2 & ""
'MsgBox "patid1 " & patid1
With ws_mainfile
Dim commandstring As String
commandstring = "=INDEX(" & firstArgument & ",MATCH(1,(" & secondArgument & "=" & condition1 & ")*(" & thirdArgument & "=" & condition2 & ")*(" & patid1 & "=" & condition3 & "),0))"
ws_mainfile.Range("AN" & j).FormulaArray = commandstring
End With
Next j
The debugger is saying the error is at the ws_mainfile.Range... = commandstring line.
condition3 = "Sheet3!" & "D2:" & D & j & ""
patid1 = "Sheet2!" & "D2:" & D & lastFullRow2 & ""
Have you defined a variable D and what is its value?
Maybe you meant:
condition3 = "Sheet3!" & "D2:D" & j
patid1 = "Sheet2!" & "D2:D" & lastFullRow2
There's also no need to concatenate an empty string onto the end of those lines.