COPIAR E COLAR EM DESTINO ESPECÍFICO

[renanem]

Boa tarde a todos do fórum!
Venho tirar uma dúvida de VBA com vocês.
É um trivial de copiar valores de um arquivo e colar em outro, porém tem um detalhe que está me travando, e vejo muitas dicas boas que tem ajudado a solucionar problemas aqui no fórum.

Tenho um Excel com a aba Orig

Tenho meu Excel destino já com a aba Dest

o ultimo valor da Orig coluna B vai na primeira linha disponível da Dest coluna B, e escreva "Quantidade A" na célula da coluna A
o ultimo valor da Orig coluna C vai na primeira linha disponível da Dest coluna B também, e escreva "Quantidade B" na célula da coluna A
o ultimo valor da Orig coluna D vai na primeira linha disponível da Dest coluna B também, e escreva "Quantidade C" na célula da coluna A
assim por diante, usando da coluna B até a coluna G da Orig.

Caso o valor seja 0 (0,000 no caso da Orig), não deva colar este valor ou deva apagar apó s o código.

Tenho já descrito o código que abre a janela, pede o Excel Orig para ser importado, ele copia os dados da aba Orig, porém cola tudo na Dest sem ser na ordem que desejava.

Sub CopyQuant()
 Application.ScreenUpdating = False
 Dim flder As FileDialog
 Dim FileName As String
 Dim FileChosen As Integer
 Dim wkbSource As Workbook
 Dim wkbDest As Workbook
 Set wkbDest = ThisWorkbook
 Dim LastRowIndex As Integer
 Dim RowIndex As Integer
 Dim UsedRng As Range
 Dim npav As String
 Dim rangM As Range
 
OpenFile:
 Set flder = Application.FileDialog(msoFileDialogFilePicker)
 flder.Title = "Arquivo"
 flder.InitialFileName = "c:\"
 flder.InitialView = msoFileDialogViewSmallIcons
 flder.Filters.Clear
 flder.Filters.Add "Excel Files", "*.xls*"
 MsgBox ("Selecione o arquivo")
 FileChosen = flder.Show
 FileName = flder.SelectedItems(1)
 Set wkbSource = Workbooks.Open(FileName)
 
''''''''''''''''''''''''''''''''''''''''''''''''

 'DADOS PARA Dest
 wkbSource.Sheets("Orig").UsedRange.Copy
 ultimalinha = wkbDest.Sheets("Dest").Cells(Rows.Count, 1).End(xlUp).Row
 wkbDest.Sheets("Dest").Cells(wkbDest.Sheets("Dest").Rows.Count, "A").End(xlUp).Offset(ultimalinha + 1, 0).PasteSpecial xlPasteValues

Alguém sabe como posso dar um passo a mais neste caso?
Obrigado.

 

[Alexandre Diogo]

Após DADOS para Dest, substitua tudo por:

Dim i as long 

Dim linha as long

Linha= wkbSource.worksheets(1).range("A1").currentregion.rows.count

 

For i=2 to wkbSource.worksheets(1).range.columns.count

Ultimalinha= wkbDest.worksheets(1).range("B1").currentregion.rows.count+1

 

wkbDest.worksheets(1).cells(ultimalinha,2).value= wkbSource.worksheets(1).cells(linha,i).value

Next 

With wkbDest.worksheets(1)

.cells(1,1).value= "Quantidade A"

.cells(2,1).value= "Quantidade B"

.cells(3,1).value= "Quantidade C"

.cells(4,1).value= "Quantidade D"

.cells(5,1).value= "Quantidade E"

.cells(6,1).value= "Quantidade F"

End with 

For i=1 to wkbDest.worksheets(1).range("A1").currentregion.rows.count

 

With wkbDest.worksheets(1)

  If .cells(i,2). Value=0 then 

    .Range.rows(i).delete 

  End If 

End with

Next 

Application.ScreenUpdating = true

End sub

 

 

 

 

 

 

Editado Agosto 16, 2021 por Alexandre Diogo
Faltou parte do código