Sub DelObjects()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Sheets
On Error Resume Next
sh.DrawingObjects.Delete
sh.OLEObjects.Delete
Next sh
MsgBox "Done!"
End Sub
Sub spot_break_rev()
Dim Arr() As Variant
Dim Temp As Variant
Dim Txt As String
Dim i As Long
Dim j As Long
Dim lr As Long
Dim k As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
With Cells.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Allocate value to dynamic array
ReDim Arr(0 To lr - 2)
'Fill the array with the keys from the Dictionary
For i = 0 To lr - 2
Arr(i) = Cells(i + 2, "A") & "^" & Cells(i + 2, "C") & "~" & i + 2
Next i
'Sort the array using the bubble sort method
'Sory by emp code
For i = LBound(Arr) To UBound(Arr) - 1
For j = i + 1 To UBound(Arr)
If Arr(i) > Arr(j) Then
Temp = Arr(j)
Arr(j) = Arr(i)
Arr(i) = Temp
End If
Next j
Next i
'Sort the array using the bubble sort method
'Sory by date if any left out
For i = LBound(Arr) To UBound(Arr) - 1
For j = i + 1 To UBound(Arr)
If Split(Arr(i), "^")(0) = Split(Arr(j), "^")(0) Then
If Split(Arr(i), "^")(0) > Split(Arr(j), "^")(0) Then
Temp = Arr(j)
Arr(j) = Arr(i)
Arr(i) = Temp
End If
End If
Next j
Next i
For i = LBound(Arr) To UBound(Arr) - 1
k = 0
If Split(Arr(i), "^")(0) = Split(Arr(i + 1), "^")(0) Then
If (CDate(Split(Split(Arr(i), "^")(1), "~")(0)) + 1) * 1 <> _
(CDate(Split(Split(Arr(i + 1), "^")(1), "~")(0))) * 1 Then
If Day(CDate(Split(Split(Arr(i + 1), "^")(1), "~")(0))) <> 7 Then
If Cells(Split(Arr(i + 1), "~")(1), "D") <> 6 Then 'chage column no. of days
Cells(Split(Arr(i + 1), "~")(1), "A").EntireRow.Interior.Color = vbYellow
End If
End If
End If
k = k + 1
End If
If k = 0 Then
Cells(Split(Arr(i), "~")(1), "A").EntireRow.Interior.Color = vbYellow
End If
If k = 0 And i = UBound(Arr) - 1 Then
Cells(Split(Arr(i), "~")(1) + 1, "A").EntireRow.Interior.Color = vbYellow
End If
Next i
End Sub
Option Explicit
Sub Generate_Diff_V2()
Dim key As Variant
Dim cell As Range, cell2 As Range
Dim wb As Workbook
Dim i As Integer, j As Integer
Dim dict As Object, dict2 As Object
Dim cell3 As Range
Set wb = ThisWorkbook
Dim app
Set app = Application.WorksheetFunction
Set dict = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
dict.RemoveAll
dict2.RemoveAll
For i = 1 To wb.Worksheets.Count
If Sheets(i).Name <> "Output" Then
Sheets(i).Select
For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Not dict.exists(Val(cell)) Then
dict.Add Val(cell), cell.Offset(0, 1)
End If
Next
For Each cell In Range(Range("C1"), Cells(1, Range("A1").End(xlToRight).Column))
If Not dict2.exists(cell.Value) Then
dict2.Add cell.Value, cell.Value
End If
Next
End If
Next i
Sheets("Output").Select
Cells.Clear
Cells(3, 1).Resize(dict.Count) = Application.Transpose(dict.Keys)
For Each cell3 In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
cell3.Offset(0, 1).Value = dict(Val(cell3))
Next cell3
Dim k As Integer
Dim rr As Long, cc As Long
k = 2
Cells(2, 1).Value = "ID"
Cells(2, 2).Value = "Name"
For Each key In dict2.Keys
For i = 1 To Worksheets.Count
If Sheets(i).Name <> "Output" Then
Cells(1, k + 1).Value = key
Cells(2, k + 1).Value = Sheets(i).Name
On Error Resume Next
cc = 0
cc = Sheets(i).Range("A1:ZZ1").Find(key, LookIn:=xlValues).Column
For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
On Error Resume Next
rr = 0
rr = Sheets(i).Range("A1:A100000").Find(cell.Value, LookIn:=xlValues).Row
If rr <> 0 And cc <> 0 Then
cell.Offset(0, k).Value = Sheets(i).Cells(rr, cc).Value
Else
cell.Offset(0, k).Value = 0
End If
Next cell
k = Range("ZZ3").End(xlToLeft).Column 'k + 6
End If
Next i
Cells(2, k + 1).Value = "Diff"
For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
'For j = 1 To Worksheets.Count - 1 'dict2.Count
'cell.Offset(0, k).Value = cell.Offset(0, k).Value - cell.Offset(0, k - j).Value
'Next j
j = Worksheets.Count - 1
cell.Offset(0, k).Value = app.Max(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1))) _
= app.Min(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1)))
If Not cell.Offset(0, k).Value Then
cell.Offset(0, k).Interior.Color = vbRed
End If
Next cell
k = Range("ZZ3").End(xlToLeft).Column + 1 'k + 6
Next key
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub ConsolEmail()
Dim objMailItems As Items
Dim objMail As Object
Dim ns As NameSpace
Dim mFound As Boolean
Set ns = Application.GetNamespace("MAPI")
Set objMailItems = ns.GetDefaultFolder(olFolderInbox).Items
'Assign the email address to forward items to
Dim msgList As String
msgList = "vba@vabs.in"
'Assign Subject
Dim msgSub As String
msgSub = "Excel"
mFound = False
'Create new email
Dim objNewMail As Object
Set objNewMail = Application.CreateItem(olMailItem)
'Forward each item as attachment
For Each objMail In objMailItems
'Debug.Print objMail.Subject
If objMail.UnRead = True And _
InStr(1, objMail.Subject, msgSub, vbTextCompare) > 1 Then
objNewMail.Attachments.Add objMail
objMail.UnRead = False
mFound = True
End If
Next
If mFound Then
objNewMail.To = msgList
objNewMail.Subject = "Group email for " & msgSub
'objNewMail.Save
objNewMail.Display
'objNewMail.Send ' untag this line for sending email instead of displaying
End If
MsgBox "One operation completed"
Set objMail = Nothing
Set objMailItems = Nothing
Set objNewMail = Nothing
End Sub
Option Explicit
Sub Merge_All_Excel()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sn(9999) As String
Dim xDir$, fName As String
Dim sheetname As String
Dim master As Workbook, import As Worksheet, file2 As Workbook
Dim r As Long, i As Long
Dim xt As String
Dim lr As Long
Set master = ThisWorkbook
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.ThisWorkbook.Path & "\"
.Title = "Please select a folder containing files"
.Show
If .SelectedItems.Count <> 0 Then
xDir$ = .SelectedItems(1) & "\"
End If
End With
fName = Dir(xDir$)
r = 1
Do While Len(fName) > 0
If UCase(Split(fName, ".")(UBound(Split(fName, ".")))) = "CSV" Or _
Left(UCase(Split(fName, ".")(UBound(Split(fName, ".")))), 2) = "XL" Then
sn(r) = fName
r = r + 1
End If
fName = Dir
Loop
On Error Resume Next
For i = 1 To r - 1
Workbooks.Open xDir$ & sn(i), ReadOnly:=True
Set file2 = ActiveWorkbook
Set import = file2.ActiveSheet
import.Copy After:=master.Sheets(master.Sheets.Count)
file2.Close False
master.Sheets(Sheets.Count).Activate
xt = Split(sn(i), ".")(UBound(Split(sn(i), ".")))
sheetname = Replace(sn(i), "." & xt, "")
master.ActiveSheet.Name = sheetname
Next i
Dim shCount As Integer
Dim col As Integer
Dim sh As Worksheet
Dim dRng As Range
Dim cell As Range
Dim LastCell As Range
Dim rng2 As Range
Set sh = Sheets("MASTER")
sh.Activate
sh.Cells.Clear
shCount = Sheets.Count
col = 1
For i = 1 To shCount
If Sheets(i).Name <> "MASTER" Then
Sheets(i).Activate
Set dRng = sh.Cells(1, col)
dRng.Resize(1, 2).Value = Sheets(i).Name
lr = Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row
Set dRng = sh.Cells(2, col)
Sheets(i).Range("A1:B" & lr).Copy
sh.Select
dRng.PasteSpecial xlPasteValues
col = col + 2
End If
Next
sh.Activate
Application.CutCopyMode = False
Cells.Columns.AutoFit
Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row, Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
Set rng2 = Range(Range("A3"), LastCell)
For Each cell In rng2
If cell.Value <> "" Then
cell.Value = Right(cell.Value, 10)
End If
Next cell
Cells.Columns.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done", Title:="www.ExcelVbaLab.Com"
Range("A1").Select
End Sub
Option Explicit
Sub copy_data_from _two_sheets_to_Summary_sheet()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Set sh1 = Sheets("File 1")
Set sh2 = Sheets("File 2")
Set sh3 = ThisWorkbook.ActiveSheet
sh3.[A2].Resize([A2].End(xlDown).Row - 1, 1).EntireRow.Clear
Set Rng = sh3.Range([A1], [A1].End(xlToRight))
For Each c In Rng
'Copy data from Sheet 1
Set sCell = sh1.Range("1:1").Find(What:=c.Value, LookIn:=xlValues)
If Not sCell Is Nothing Then
rSize = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Else
c.Offset(1, 0).Resize(rSize, 1).Value = sh1.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
End If
End If
'Copy data from Sheet 2
Set sCell = sh2.Range("1:1").Find(What:=c.Value, LookIn:=xlValues)
If Not sCell Is Nothing Then
rSize = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
c.End(xlDown).Offset(1, 0).Resize(rSize, 1).Value = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
Else
c.Offset(1, 0).Resize(rSize, 1).Value = sh2.Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Value
End If
End If
Next
MsgBox "Done"
End Sub
Option Explicit
Sub Compare_List_Diff()
Dim arrM, d As Object, rngM As Range
Dim arrT, d2 As Object, rngT As Range
Dim r As Integer
Dim wsM As Worksheet, wsT As Worksheet, wsR As Worksheet
Dim iRW As Integer, iCL As Integer
Dim LastCell As Range, LastCell2 As Range, LastCell3 As Range
Dim wsMlr As Integer, wsMlc As Integer
Dim wsTlr As Integer, wsTlc As Integer
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set wsM = Worksheets("Sheet1")
Set wsT = Worksheets("Sheet2")
Set wsR = Worksheets("Diff")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.AskToUpdateLinks = False
End With
'get last row of Main
wsM.Select
Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
wsMlr = LastCell.Row
wsMlc = LastCell.Column
wsT.Select
Set LastCell2 = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
wsTlr = LastCell2.Row
wsTlc = LastCell2.Column
wsR.Select
Set LastCell3 = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
wsR.Range("2:" & LastCell3.Row).Clear
For iRW = 2 To wsTlr
'trf main sheet row data to arr and store in dict
Set rngM = wsM.Range(wsM.Cells(iRW, 2), wsM.Cells(iRW, wsMlc))
arrM = Application.Transpose(rngM)
'arr = Application.Transpose(wsM.Range(wsM.Cells(iRW, 2), wsM.Cells(iRW, wsMlc)))
For r = 1 To UBound(arrM, 1)
If arrM(r, 1) <> "" Then
d(arrM(r, 1)) = 1
End If
Next r
'trf second sheet row data to range and then to array
wsT.Select
Set rngT = wsT.Range(wsT.Cells(iRW, 2), wsT.Cells(iRW, wsTlc))
arrT = Application.Transpose(rngT.Value) 'values from range to array
For r = 1 To UBound(arrT, 1)
If arrT(r, 1) <> "" Then
d2(arrT(r, 1)) = 1
End If
Next r
'check values in array agst dict
'Erase arrN()
wsR.Cells(iRW, 1).Value = wsT.Cells(iRW, 1).Value
wsR.Cells(iRW, 2).Value = "Row " & iRW
For r = 1 To UBound(arrT, 1)
If Not d.exists(arrT(r, 1)) Then
'arrN(r, 1) = arrV(r, 1)
''wsR.Cells(iRW, r + 1).Value = arrT(r, 1)
wsR.Cells(iRW, "IV").End(xlToLeft).Offset(0, 1).Value = arrT(r, 1)
End If
Next r
For r = 1 To UBound(arrM, 1)
If Not d2.exists(arrM(r, 1)) Then
'arrN(r, 1) = arrV(r, 1)
''wsR.Cells(iRW, r + 1).Value = arrM(r, 1)
wsR.Cells(iRW, "IV").End(xlToLeft).Offset(0, 1).Value = arrM(r, 1)
End If
Next r
Next iRW
wsR.Select
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.AskToUpdateLinks = True
End With
MsgBox "Done"
End Sub
Sub Sort_Active_Book_AlphaNum()
Dim i As Integer
Dim j As Integer
Dim a As Integer, b As Integer, Sn1 As String, Sn2 As String
Dim iAnswer As VbMsgBoxResult
Dim c As String
'
' Prompt the user as which direction they wish to
' sort the worksheets.
'
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
& "Clicking No will sort in Descending Order", _
vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1 'Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
If iAnswer = vbYes Then
Sn1 = "": Sn2 = ""
For a = 1 To Len(Sheets(j).Name)
If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then
Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)
End If
Next a
For b = 1 To Len(Sheets(j + 1).Name)
If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then
Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)
End If
Next b
If a <> 0 Then
If Val(Sn1) > Val(Sn2) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
Else
If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
'
' If the answer is No, then sort in descending order.
'
ElseIf iAnswer = vbNo Then
Sn1 = "": Sn2 = ""
For a = 1 To Len(Sheets(j).Name)
If VBA.IsNumeric(Mid(Sheets(j).Name, a, 1)) Then
Sn1 = Sn1 & Mid(Sheets(j).Name, a, 1)
End If
Next a
For b = 1 To Len(Sheets(j + 1).Name)
If VBA.IsNumeric(Mid(Sheets(j + 1).Name, b, 1)) Then
Sn2 = Sn2 & Mid(Sheets(j + 1).Name, b, 1)
End If
Next b
If a <> 0 Then
If Val(Sn1) < Val(Sn2) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
Else
If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
End If
Next j
Next i
End Sub
Option Explicit
Sub Macro1()
Dim Rng As Range, c As Range
Dim sCell As Range
Dim rSize As Long
Dim dest As Range
Dim lDestRow As Long
Dim i As Integer
Sheets("Base Sheet").Select
i = 0
Set Rng = Range([D1], [D1].End(xlToRight))
For Each c In Rng
Set sCell = Sheets("Roster").Range("1:1").Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
rSize = Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Cells.Count
If c.Offset(1, 0).Value <> "" Then
Set dest = c.End(xlDown).Offset(1, 0)
If i = 0 Then
lDestRow = dest.Row
End If
If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If
Sheets("Roster").Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
dest.Select
ActiveSheet.Paste
Else
Range(sCell.Offset(1, 0), sCell.End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Set dest = c.Offset(1, 0)
If dest.Row < lDestRow Then
Set dest = Cells(lDestRow, dest.Column)
End If
dest.Select
ActiveSheet.Paste
End If
i = i + 1
Next
End Sub
Cheers!!Option Explicit Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal hwnd As Long, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long Public Function PrintThisDoc(formname As Long, FileName As String) On Error Resume Next Dim X As Long X = ShellExecute(formname, "Print", FileName, 0&, 0&, 3) End Function Sub print_hyp_doc() Dim c As Range, rng As Range Dim shp As Shape Dim printThis Set rng = Selection.SpecialCells(xlCellTypeVisible) On Error Resume Next For Each c In rng For Each shp In ActiveSheet.Shapes If shp.TopLeftCell.Address = c.Address Then Debug.Print shp.Hyperlink.Address 'shp.Hyperlink.Follow NewWindow:=True 'printThis = PrintThisDoc(0, strDir & "\" & strFile) printThis = PrintThisDoc(0, shp.Hyperlink.Address) End If Next shp Next End Sub
Public WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
Dim endOfSubject As String
Dim destFolder As String
Dim myCode As String
Dim sName As String
Dim regEx As Object
Dim matches
sName = Item.Subject
ReplaceCharsForFileName sName, "_"
If TypeName(Item) = "MailItem" Then
Set msg = Item
' check if subject field contains CODE
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Pattern = "\w+\d{5}"
.IgnoreCase = True
.Global = True
End With
If regEx.Test(Item.Subject) Then
Set matches = regEx.Execute(Item.Subject)
myCode = matches(0)
Else
Exit Sub
End If
destFolder = "C:/EmpPersonal/"
destFolder = destFolder & myCode
' if subfolder doesn't exist, create it
If Dir(destFolder, vbDirectory) = "" Then
MkDir destFolder
End If
' Copy msg to local folder
Item.SaveAs destFolder & "/" & sName & ".msg", olMSG
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
'Requires additional references to Microsoft Internet Control 'Requires additional HTML object library Public Function URLDecode(url$) As String With CreateObject("ScriptControl") .Language = "JavaScript" URLDecode = .Eval("unescape(""" & url & """)") End With End Function Public Sub Fetch_Image() Dim IE As InternetExplorer Dim HTMLdoc As HTMLDocument Dim imgElements As IHTMLElementCollection Dim imgElement As HTMLImg Dim aElement As HTMLAnchorElement Dim n As Integer, i As Integer Dim url As String, url2 As String, furl as string Dim m, lastRow As Long lastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To lastRow url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&source=lnms&tbm=isch&sa=X&rnd=1" Set IE = New InternetExplorer With IE .Visible = False .navigate url Do Until .readyState = 4: DoEvents: Loop 'Do Until IE.document.readyState = "complete": DoEvents: Loop Set HTMLdoc = .document Set imgElements = HTMLdoc.getElementsByTagName("IMG") n = 1 For Each imgElement In imgElements If InStr(imgElement.src, sImageSearchString) Then If imgElement.ParentNode.nodeName = "A" Then Set aElement = imgElement.ParentNode If n = 2 Then url2 = aElement.href url3 = imgElement.src GoTo done: End If n = n + 1 End If End If Next done: furl = InStrRev(url2, "&imgrefurl=", -1) furl = Mid(url2, 40, furl - 40) furl = URLDecode(furl) Cells(i, 2) = furl Set m = ActiveSheet.Pictures.Insert(furl) With Cells(i, 3) t = .Top l = .Left w = .Width h = .Height End With With m .Top = t .Left = l .ShapeRange.Width = w .ShapeRange.Height = h End With IE.Quit Set IE = Nothing End With Next MsgBox "Done!!" End Sub