Criei a rotina abaixo para fazer o que deseja.
Código: Selecionar todos#If VBA7 Then
Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr _
, ByVal szURL As String _
, ByVal szFileName As String _
, ByVal dwReserved As LongPtr _
, ByVal lpfnCB As LongPtr) As Long
#Else
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long _
, ByVal szURL As String _
, ByVal szFileName As String _
, ByVal dwReserved As Long _
, ByVal lpfnCB As Long) As Long
#End If
'Primeira macro a ser executada
Sub CriarPastas()
Dim fso As Object
Dim path As String
Set fso = CreateObject("Scripting.FileSystemObject")
'cria a pasta imoveis junto desta planilha
path = ThisWorkbook.path & Application.PathSeparator & "imoveis"
If Not fso.FolderExists(path) Then
fso.CreateFolder (path)
End If
'cria uma sub pasta para cada imovel na pasta imoveis
For i = 2 To 21 'numero de imoveis
path = ThisWorkbook.path & Application.PathSeparator & "imoveis" & Application.PathSeparator & ThisWorkbook.Worksheets("imoveis").Cells(i, 1)
If Not fso.FolderExists(path) Then
fso.CreateFolder (path)
End If
Next
End Sub
'cria arquivo com dados do imóvel na pasta criada anteriormente
Sub CriarArquivos()
'variáveis
Dim newBook As Workbook
Dim sheet As Worksheet
Dim i As Long
'Desativa os avisos e atualiação da tela
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 2 To 21 'numero de imoveis
'cria uma nova pasta de trabalho:
Set newBook = Application.Workbooks.Add
'cria a planilha
Set sheet = newBook.Worksheets.Add
sheet.Name = "Dados do Imóvel"
'salva os dados
For j = 1 To 7 'numero de colunas com os dados do imóvel
sheet.Cells(j, 1) = Plan8.Cells(1, j)
sheet.Cells(j, 2) = Plan8.Cells(i, j)
Next j
'remove as outras planilhas
For k = 2 To newBook.Worksheets.Count
newBook.Worksheets(2).Delete
Next k
'salva o arquivo
newBook.SaveAs ThisWorkbook.path & Application.PathSeparator & "imoveis" & Application.PathSeparator & ThisWorkbook.Worksheets("imoveis").Cells(i, 1) & Application.PathSeparator & "Dados do Imóvel.xlsx"
newBook.Close
Next
End Sub
Sub BaixarFotos()
'Declaração de variáveis
Dim sURL As String
Dim sDestino As String
Dim blSucesso As Boolean
For i = 2 To 203 ' número de fotos
'url e destino
sURL = ThisWorkbook.Worksheets("imoveis_fotos").Cells(i, 3)
sDestino = ThisWorkbook.path & Application.PathSeparator & "imoveis" & Application.PathSeparator & _
ThisWorkbook.Worksheets("imoveis_fotos").Cells(i, 2) & Application.PathSeparator & ThisWorkbook.Worksheets("imoveis_fotos").Cells(i, 1) & ".jpg"
'baixa o arquivo da internet
blSucesso = DownloadArquivo(sURL, sDestino)
ThisWorkbook.Worksheets("imoveis_fotos").Cells(i, 4) = blSucesso
Next i
End Sub
'função de apoio
Private Function DownloadArquivo(sURL As String, sDestino As String) As Boolean
Dim l As Long
l = URLDownloadToFile(0, sURL, sDestino, 0, 0)
If l = 0 Then DownloadArquivo = True
End Function
Sub executa_tudo()
Call CriarPastas
Call CriarArquivos
Call BaixarFotos
MsgBox "Pronto! Foi criada uma pasta chamada imoveis no mesmo local deste arquivo"
End Sub
Referências:
http://www.ambienteoffice.com.br/office ... _arquivos/
Você não está autorizado a ver ou baixar esse anexo.