Guru do Excel e Power BI

Enviado: **23 Jan 2023 às 10:20**

Bom dia, Pessoal

Sou novato aqui e tambem na linguagem VBA.
Tenho o código abaixo que foi copiado de algum lugar da internet, estou adaptando mas sem sucesso.
Essa macro faz um loop de 4 vezes e deve pular para o proxima linha e refazer o loop ate terminar de colar as imagens, mas o mesmo so faz uma vez e termina.
Tem duas pastas uma com os codigos dos produtos e outra onde eu monto o catalogo de produtos

Public UL As Integer
Sub seq()
Dim caminho As String
Dim LOCAL1 As String
Dim lin As Integer
lin = 2
' (CATALOGO) aPAGAR AS IMAGENS PARA NOVA COLAGEM
Range("B4").Select
Planilha1.DrawingObjects.delete
'----------------------------------------------------------------
' (Lista) ver o numero de linhas
Do
Planilha5.DrawingObjects.Select
UL = Sheets("LISTA").Cells(Cells.Rows.Count, 2).End(xlUp).Row
'-----------------------------------------------------------------
' (Lista) posicionar na primeira linha
'Do While UL <> 0
'UL = UL - 1
With Planilha5
For lin = lin To 5
caminho = ThisWorkbook.Path & "\" & .Range("a" & lin) & ".jpg"
Set ShpImagem = .Shapes("moldura")
With ShpImagem
.Fill.UserPicture picturefile:=caminho
End With
.Range("F1").Copy
Planilha1.Activate
Planilha1.Pictures.Paste
ActiveCell.Offset(0, 3).Select
lin = lin
Next
End With
ActiveCell.Offset(3, -12).Select
Loop
End Sub

Enviado: **23 Jan 2023 às 12:10**

Olá, Luiz.

Sugestão: anexe diretamente aqui no fórum uma amostra do seu arquivo Excel com as imagens e com o código instalado.

Deixe de lado um momento o seu código e descreva com exatidão na própria planilha o que você deseja fazer via macro.

obs. para facilitar a leitura, ao postar códigos VBA, selecione o código colado e aperte o ícone </> no cabeçalho da sua mensagem.

Enviado: **23 Jan 2023 às 12:37**

Gerar_Lista_Novo.xlsm

Ola Osvaldo,

Essa macro seria para um catalogo de produtos.
Copia conforme relaçao dos codigos da planilha lista e cola na planilha catalogo, ou seja faz 4 quatro vez a colagem e depois desce algumas linhas começa a colar mais 4 vezes e assim até terminar conforme a planilha lista

Obrigado,

Enviado: **23 Jan 2023 às 16:54**

Olá, Luiz.

Veja se este código lhe atende.

Código: Selecionar todos

Sub seqV2()
 Dim UL As Long, lin As Long, k As Long, i As Long, caminho As String, ShpImagem As Shape
  Application.ScreenUpdating = False
  Planilha1.DrawingObjects.delete
  With Sheets("LISTA")
   UL = .Cells(Rows.Rows.Count, 2).End(xlUp).Row
   Set ShpImagem = .Shapes("moldura")
   For lin = 2 To UL
    caminho = ThisWorkbook.Path & "\" & .Range("A" & lin) & ".jpg"
    ShpImagem.Fill.UserPicture picturefile:=caminho
    .Range("F1").Copy
     Planilha1.Paste Cells(k + 4, i + 2)
     i = i + 3: If i > 11 Then k = k + 3: i = 0
   Next lin
  End With
End Sub

Enviado: **25 Jan 2023 às 12:39**

Boa tarde, Osvaldo
O codigo resolveu minha duvida

Tenho outra duvida que e referente ao codigo abaixo que seria redimensionar somente uma imagem do arquivo no caso a que estiver selecionada e nao todas

Código: Selecionar todos

Sub AjustaTamanho()
     For Each sh In ActiveSheet.Shapes
        If sh.Name Like "*Pict*" Then
        ActiveSheet.Shapes.Range(Array(sh.Name)).Select
          With Selection
            .Top = sh.TopLeftCell.Top
            .Left = sh.TopLeftCell.Left
            .ShapeRange.Height = 130
            .ShapeRange.Width = 130
          End With
        End If
    Next
End Sub

obrigado

Enviado: **25 Jan 2023 às 15:23**

luizmaglia escreveu: ↑25 Jan 2023 às 12:39 ... redimensionar somente uma imagem ... que estiver selecionada ...

Código: Selecionar todos

Sub AjustaTamanho()
          With Selection
            .Top = sh.TopLeftCell.Top
            .Left = sh.TopLeftCell.Left
            .ShapeRange.Height = 130
            .ShapeRange.Width = 130
          End With
End Sub

Mantive no seu código somente as linhas de interesse.
Selecione manualmente a imagem e rode o código. Veja se atende.

Enviado: **25 Jan 2023 às 16:12**

Boa tarde,

Nao rodou veja o erro
Erro em tempo de execucao 424

O objeto e obrigatorio

Enviado: **25 Jan 2023 às 17:31**

Desculpe, falha minha.

Remova também as duas ocorrências de sh #(mantenha o ponto que está à direita).

Enviado: **25 Jan 2023 às 18:25**

Blz funcionou perfeito

Muito obrigado

abs

Guru do Excel e Power BI

LOOPS

LOOPS

Re: LOOPS

Re: LOOPS

Re: LOOPS

Re: LOOPS

Re: LOOPS

Re: LOOPS

Re: LOOPS

Re: LOOPS