Narciso Felizardo

Olá colegas, estou elaborando uma planilha que funciona da seguinte maneira: Os colaboradores tiram fotos de ANTES e DEPOIS de situaçoes anormais no local de trabalho, depois pegamos essas imagens e para cada ANTES e DEPOIS fazemos um ''INFORME'', imagine que o colaborador tenha tirado 100 fotos , então serão 50 informes, porém o trabalho se torna repetitivo. O que eu gostaria é de selecionar todas as 100 fotos de uma vez só, redimensionar e compactar (já foi feito), depois criar as 50 planilhas (já foi feito) e por último, que é o meu problema... pegas essas 100 imagens ou x imagens e recortar e colar nas 50 planilhas ou x planilhas geradas de forma sequencial. Ou seja : pegas as 2 primeiras imagens recortar e colar na aba seguinte, depois as 2 imagens posteriores recortar e colar na aba seguinte, e assim por diante. segue o código usado até agora: Sub copiarpastas() Dim k As Long k = ThisWorkbook.Sheets.Count Dim Pict Dim ImgFileFormat As String Dim Celula As String Celula = "C21" ' celula que será inserido a imagem ImgFileFormat = "Image Files JPG (*.jpg),*.jpg,Image Files JPEG (*.jpeg),*.jpeg, Image Files PNG (*.png),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp" 'Pict = Application.GetOpenFilename(ImgFileFormat, False, False, MultiSelect:=True) Pict = Application.GetOpenFilename(ImgFileFormat, False, False, False, True) 'If Pict = False Then End If IsArray(Pict) Then 'IF ARRAY If UBound(Pict) <= 50 Then 'IF I 'copiar as pastas n vezes Dim x As Integer x = UBound(Pict) / 2 For numtimes = 1 To x 'Loop by using x as the index number to make x number copies. 'Replace "Sheet1" with the name of the sheet to be copied. ActiveWorkbook.Sheets(" ").Copy _ After:=ActiveWorkbook.Sheets(" ") Sheets(" ").Select Next For i = LBound(Pict) To UBound(Pict) 'FOR I Select Case i 'Cobertura de 50 imagens Case 1 To 50 'IMAGEM: largura = 4 colunas; altura= 11 linhas Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _ Range(Celula).Top, Range(Celula).Width + 298, Range(Celula).Height * 1 End Select Next i 'FOR I Else 'IF I MsgBox "Selecionar no máximo 50 imagens" End End If 'IF I End If 'IF ARRAY 'If Pict = False Then End 'Application.ActiveSheet.Shapes.AddPicture Pict, False, True, Range(Celula).Left, _ 'Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11 'IMAGEM: largura = 30 colunas; altura= 13 linhas End Sub estou disponibilizando a planilha também Anticontaminação_2019_OUT_NARCISO(001-130).rar